3:12 PM 18-NOV-98 ACHS*3*6 CORRECTIONS TO PROBLEMS TRANSMITTING TO HAS ACHSA5 ACHSA5 ; IHS/ADC/GTH - ENTER DOCUMENTS (6/8)-(SCC,DCR,DEST,REF,COM,DAYS) ; [ 11/18/1998 3:09 PM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**5**;SEP 17, 1997 ;;ACHS*3*5 FIX 1999 CAN SELECTION LOGIC ; B1 ;EP - Input Service Class Code. W !!,"Service Class Code: " I ACHSSCC,$D(ACHSSAME),ACHSSAME=ACHSCAN,$D(^ACHS(3,DUZ(2),1,ACHSSCC,0)) W $P(^(0),U),"// " S ACHSSAME=ACHSCAN D READ^ACHSFU I Y="",ACHSSCC S Y=$P(^ACHS(3,DUZ(2),1,ACHSSCC,0),U) E S ACHSSCC="" G A1^ACHSA4:$D(DUOUT),END:ACHSQUIT,B5:Y'?1"?".E S (R,ACHSCT)=0 W !!?3,"ITEM #",?12,"SER CL",?20,"DESCRIPTION",!?3,"------",?12,"------",?20,"-----------",! B2 ; S R=$O(^ACHS(3,DUZ(2),"AC",ACHSCC,R)) G B4:R="" S ACHS=$P(^ACHS(3,DUZ(2),1,R,0),U) I $D(ACHSBLKF),((ACHS="252G")!(ACHS="252R")!(ACHS="254B")!(ACHS="254P")) G B2 I ACHSTYP=1,+ACHS=252,("FGMR"[$E(ACHS,4)) G B3 I ACHSTYP=2,((ACHS="252D")!(ACHS="254E")) G B3 G B2:ACHSTYP'=3,B2:((+ACHS=252)&("DFGM"[$E(ACHS,4)))!(ACHS="254E") B3 ; D OBJCHK I '$D(ACHSOBOK) G B2 B3A ; S ACHSCT=ACHSCT+1,ACHS(ACHSCT)=R W !?5,$J(ACHSCT,3),?12,$P(^ACHS(3,DUZ(2),1,R,0),U),?20,$P(^(0),U,2) I '(ACHSCT#18),'$$DIR^XBDIR("E") G B4 G B2 ; B4 ; I ACHSCT=0 W *7,!,"No SERVICE CLASS CODES for CAN.",!!,"Notify Site Manager.",! S ACHSSCC="" G A1^ACHSA4 W !!?20,"SELECT ITEM (1-",ACHSCT,") " D READ^ACHSFU G ACHK^ACHSA4:$D(DUOUT),END:ACHSQUIT,ACHK^ACHSA4:Y="",B4:Y<1!(Y>ACHSCT) S ACHSSCC=ACHS(Y),Y=$P(^ACHS(3,DUZ(2),1,ACHSSCC,0),U) W " ",Y B5 ; I Y["." S Y=$P(Y,".")_$P(Y,".",2,99) S:Y]"" ACHSDCR="" I Y="",ACHSSCC]"" S Y=$P(^ACHS(3,DUZ(2),1,ACHSSCC,0),U) G B6 I Y,'$D(^ACHS(3,DUZ(2),1,"B",Y)) S Y="" I Y="" W *7," Required" G B1 I +Y=0 G B1 B6 ; S ACHSOBJC=$$STO(Y) I $D(ACHSBLKF),((Y="252G")!(Y="252R")!(Y="254B")!(Y="254P")) D NOBLK^ACHSAB G B1 I ACHSTYP=2 G B8:Y="252D"!(Y="254E") W !!,*7," ONLY 252D or 254E FOR DENTAL." G B1 I ACHSTYP=1 G B8:(+Y=252)&("FGMR"[$E(Y,4)) W !!,*7," ONLY 252G, 252M, 252F OR 252R FOR HOSPITAL CARE" G B1 I ACHSTYP=3,Y="252G"!(Y="252M") W *7,"INVALID INPATIENT SERVICE CLASS." G B1 B8 ; I ACHSSCC G B9 I $L(Y)=4 S X=$O(^ACHS(3,DUZ(2),1,"B",Y,"")) I X,$D(^ACHS(3,DUZ(2),1,X,0)),'$P(^(0),U,3),'$O(^ACHS(3,DUZ(2),1,"B",Y,X)) S ACHSSCC=X G B9 W *7," ??" G B1 ; B9 ; S R=ACHSSCC D OBJCHK I '$D(ACHSOBOK) W " ",*7,"INVALID SERVICE CLASS" G B1 KILL ACHSOBOK,ACHSOBIF D ^ACHSLDCR G B1:ACHSDCR=-1 I 'ACHSDCR W *7,!!,"Unspecified DCR For CAN/SERVICE CLASS CODE pair" S ACHSSCC="" G A1^ACHSA4 B10 ; I +ACHSDCR W !!,"DCR ACCOUNT = ",$P(^ACHS(9,DUZ(2),"RN"),U,ACHSDCR) S ACHSOBJC=$$STO($P(^ACHS(3,DUZ(2),1,ACHSSCC,0),U)) I ACHSOBJC=-1 W !,"WARNING - NO EQUIVALENT OBJECT CLASS CODE.",!,"USING SERVICE CLASS CODE." S ACHSOBJC=ACHSSCC G B10A W !,"OBJECT CLASS CODE = ",$E(ACHSOBJC,1,2),".",$E(ACHSOBJC,3,4) S ACHSOBJC=$O(^ACHSOCC("B",ACHSOBJC,0)) ; Convert to Pointer. W " : ",$P(^ACHSOCC(ACHSOBJC,0),U,2) B10A ; S ACHSDEST=$P(^ACHS(3,DUZ(2),1,ACHSSCC,0),U,3) S:ACHSDEST'="F" ACHSDEST="I" I $$PARM^ACHS(2,3)'="Y",ACHSDEST="F",$D(ACHSBLKF) G BLKERR B11 ; W ! S DIR(0)="9002080.01,13.5" S:ACHSDEST]"" DIR("B")=ACHSDEST D ^DIR KILL DIR G ACHK^ACHSA4:$D(DUOUT),END:$D(DTOUT) S ACHSDEST=Y D:ACHSDEST="F" SSNCHK B12 ; Check blanket parm., input Dental Referral Type. I $$PARM^ACHS(2,3)'="Y",ACHSDEST="F",$D(ACHSBLKF) W *7,!,"SITE PARAMETER PREVENTS ISSUE OF BLANKET FOR FI DOCUMENT." G B10 S:'$D(ACHSREFT) ACHSREFT="" G C1:'((ACHSTYP=2)&(ACHSDEST="F")) W ! S DIR(0)="9002080.01,83.12",DIR("??")="^D DISPMPC^ACHSA5" S:ACHSREFT]"" DIR("B")=ACHSREFT D ^DIR G B11:$D(DUOUT)!$D(DTOUT),B12:$D(DIRUT) S ACHSREFT=Y KILL DIR C1 ;EP - Input optional comment. I $$PARM^ACHS(2,3)'="Y",ACHSDEST="F",$D(ACHSBLKF) G BLKERR I $D(ACHSSLOC) S ACHSCOPT="SPEC. TRNS" W !!,"Optional comments: ",ACHSCOPT G C2 W !,$$PRMT^ACHSFU(17,ACHSCOPT,10),!,"Optional Comments: " W:ACHSCOPT]"" ACHSCOPT,"// " D READ^ACHSFU G B10:$D(DUOUT),END:ACHSQUIT I Y?1"?".E W !," Enter a Comment (10 chars max) If You Wish",!," Enter An '@' To Delete Current Comment" G C1 G C2:Y="" I $L(Y)<11 S ACHSCOPT=$S(Y="@":"",1:Y) W:Y="@" " Deleted" G C2 W *7," Too Long" G C1 ; C2 ; G E1:ACHSTYP'=1 D1 ; Input estimated LOS. S:'$D(ACHSESDA) ACHSESDA="" S DIR(0)="9002080.01,25" S:ACHSESDA]"" DIR("B")=ACHSESDA D ^DIR,DIRD^ACHSFU:X="@" G C1:$D(DUOUT),END:$D(DTOUT) S ACHSESDA=Y KILL DIR I Y<15 G E1 W *7 D2 ; S Y=$$DIR^XBDIR("Y"," Are You Sure "_ACHSESDA_" Days Is Correct","NO","","","",2) G D1:$D(DUOUT),END:$D(DIRUT),D1:'Y E1 ; G ^ACHSA6 ; END ; G END^ACHSA ; BLKERR ; Blanket not allowed. W !!,*7,"Blankets only valid for IHS Payment Documents",!,"Transaction Cancelled",!!,"'",$P(^DD(9002080,14.03,0),U),"' parameter = '",$$PARM^ACHS(2,3),"'.",!! D RTRN^ACHS Q ; SSNCHK ; Check for SSN. I $D(DFN),'$P(^DPT(DFN,0),U,9) D .W *7,!!?17,"*** SSN IS MISSING FOR THIS PATIENT ***",!!?6,"Determination of billing by the Fiscal Intermediary will be greatly",!?11,"aided if you can provide the SSN before printing this PO.",!,*7 .Q Q ; OBJCHK ;EP - Check if object class inactivated. KILL ACHSOBOK S ACHSOBIF=$P(^ACHS(3,DUZ(2),1,R,0),U,4) I ACHSOBIF'="I" S ACHSOBOK="" Q S X=ACHSACFY-1701_"1001",Y=$P(^ACHS(3,DUZ(2),1,R,0),U,5) I +Y<2900000 W !,*7,?12,$P(^ACHS(3,DUZ(2),1,R,0),U,1)," INVALID INACTIVATION DATE" Q Q:X'<7 S ACHSOBOK="" Q ; DISPMPC ;EP - From call to DIR, display medical priorities W !! S %=0 F S %=$O(^DD(9002080.01,83.12,21,%)) Q:'% W !,^(%,0) I $G(^DD(9002080.01,83.12,21,%+1,0))["REFERRAL" W !,"Press RETURN..." D READ^ACHSFU Q:$G(ACHSQUIT) Q ; STO(S) ; Given an SCC, return the OCC. I '($L(S)=4) Q -1 ; SCC is 4AN. I ACHSACFY<1998 Q S ; Document must be FY98 or later. E I ACHSEDOS<$P($$FY^ACHSVAR(98),U) Q S ; Estimated Date of Service must be in FY98 or later. ;Q:'("Q"[$E($P(^ACHS(2,ACHSCAN,0),U),5)) S ; CAN must be FY98 or later. ;;ACHS*3*5 Q:'("DQ"[$E($P(^ACHS(2,ACHSCAN,0),U),5)) S ; CAN must be FY98 or later. ;;ACHS*3*5 I S>2581,S<2586 G 418 NEW O,T S O=-1 F %=1:1 S T=$P($T(DATA+%),";",3) Q:T="END" I $P(T,U)=S S O=$P(T,U,2) Q Q O ; 418 ; Ask user to ID x-walk for Tribal Ops, Contracts, or Indirect NEW DIC S DIC="^ACHSOCC(",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U)[""418""" S DIC("S")=DIC("S")_","""_$S(S=2582:"123ABC",S=2584:"4D",S=2585:"5E",1:"")_"""[$E($P(^(0),U),4)" KILL S D ^DIC I Y>0 Q $P(Y(0),U) Q -1 ; DATA ;; SCC^OCC ;;2185^2185 ;;252A^256Q ;;252B^256Q ;;252H^256Q ;;252J^256Q ;;252D^256R ;;252G^256R ;;252L^256R ;;252M^256R ;;252Q^256R ;;252S^256R ;;254B^256R ;;254D^256R ;;254E^256R ;;254G^256R ;;254J^256R ;;254L^256R ;;254A^256T ;;254C^256T ;;252Z^256Z ;;252F^256W ;;254V^256W ;;2611^2611 ;;263A^263A ;;263L^263A ;;263G^263G ;;263K^263K ;;4319^4319 ;;8116^8116 ;;END ; ACHSA6 ACHSA6 ; IHS/ADC/GTH - ENTER DOCUMENTS (7/8)-(EST. COST, MED DATA) ; [ 09/17/97 9:12 AM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**3**;SEP 17, 1997 ; A1 ; Input estimated charges. W !!,"Estimated Charges: " I ACHSESDO]"" S X=ACHSESDO,X2="2$" D FMT^ACHS W "// " D READ^ACHSFU G C1^ACHSA5:$D(DUOUT),END:ACHSQUIT I Y?1"?".E W " Enter The ",$S($D(ACHSBLKF):"Dollar Amount To Be Obligated",1:"Approximate Cost of Treatment") G A1 I Y="" G A3:ACHSESDO W *7," Must Have Amount" G A1 S:$E(Y)="$" Y=$E(Y,2,999) F S %=$F(Y,",") Q:'% S Y=$E(Y,1,%-2)_$E(Y,%,99) I '(Y?1N.N1"."2N!(Y?1N.N))!($L(Y)>10) W *7," ??" G A1 S Y=$J(Y,1,2) S ACHS=$P($G(^ACHSF(DUZ(2),"N",ACHSTYP,0)),U,2,3) I ACHS,Y'>ACHS S ACHSESDO=Y G A3 I Y>$P(ACHS,U,2) W !!,*7,"The OBLIGATION LIMIT for this type of document is " S X=$P(ACHS,U,2) D FMT^ACHS W ".",!!,"Enter a lesser amount of money or exit the document.",!! G A1 W *7 S (S,X)=Y A2 ; Confirm amount obligated. W !!?4 S X=S,X2="2$" D FMT^ACHS S Y=$$DIR^XBDIR("Y"," Are You Sure This Is Correct","NO") G A1:$D(DUOUT),END:$D(DTOUT),A1:'Y S ACHSESDO=S ; A3 ; Enter Referral Medical Priority Code I '$$AVAIL^ACHSUUP(ACHSESDO,ACHSACFY,ACHSCFY) W !!,"This amount exceeds your funds available." G A1 W ! S DIR(0)="9002080.01,81",DIR("??")="^D DISPMPC^ACHSA6" S:ACHSRMPC]"" DIR("B")=ACHSRMPC D ^DIR G A1:$D(DUOUT),KDIR:$D(DTOUT) D KDIR S ACHSRMPC=$G(Y) ; A4 ; Enter additional referral data. I (ACHSTYP=2)!$D(ACHSBLKF)!$D(ACHSSLOC) G ^ACHSA7 S Y=$$DIR^XBDIR("Y","Enter ADDITIONAL REFERRAL DATA NOW","N") G ^ACHSA7:'Y,A1:$D(DUOUT),END:$D(DTOUT) D KDIR ; RPHY ; Enter the Referral Physician. ;ACHS*3*3 MUST USE FILE 200 TO BE SAC COMPLIANT S ACHS200=$S($G(^DD(9002080.01,80,0))["VA(200,":1,1:0) ;ACHS*3*3 ;S DIC="^DIC(6,",DIC(0)="AEMQZ",DIC("A")="REFERRAL PHYSICIAN: ",DIC("S")="I '$D(^(""I""))" ;ACHS*3*3 S DIC=$S(ACHS200:200,1:"^DIC(6,"),DIC(0)="AEMQZ",DIC("A")="REFERRAL PHYSICIAN: " ;ACHS*3*3 I 'ACHS200 S DIC("S")="I '$D(^(""I""))" ;ACHS*3*3 ;S:ACHSRPHY>0 DIC("B")=$P(^DIC(16,ACHSRPHY,0),U) ;ACHS*3*3 I 'ACHS200,ACHSRPHY>0 S DIC("B")=$P(^DIC(16,ACHSRPHY,0),U) ;ACHS*3*3 D ^DIC KILL DIC G A1:$D(DUOUT),KDIR:$D(DTOUT) D KDIR S ACHSRPHY=$S($D(Y):+Y,1:"") ; RCOI ; Enter Referral Cause Of Injury. S DIR(0)="9002080.01,82" S:ACHSRCOI]"" DIR("B")=$P(ACHSRCOI,U,2) D ^DIR G A1:$D(DUOUT),KDIR:$D(DTOUT) D KDIR S ACHSRCOI=$G(Y) ; RALR ; Enter Referral Alcohol Related?. S DIR(0)="9002080.01,83" S:ACHSRALR]"" DIR("B")=ACHSRALR D ^DIR G A1:$D(DUOUT),KDIR:$D(DTOUT) D KDIR S ACHSRALR=$G(Y) ; RDX ; Enter Referral ICD DX codes. S DIR(0)="9002080.184,.01" F ACHS=1:1 S DIR("A")=$P(^DD(9002080.184,.01,0),U)_" # "_ACHS_" " S:$D(ACHSRDX(ACHS)) DIR("B")=$P(ACHSRDX(ACHS),U,2) D ^DIR KILL DIR("B") Q:$D(DIRUT) S ACHSRDX(ACHS)=Y I $D(DUOUT)!(X="@") F %=ACHS:1 Q:'$D(ACHSRDX(%)) KILL ACHSRDX(%) G A1:$D(DUOUT),KDIR:$D(DTOUT) D KDIR ; RDXN ; Enter Referral Diagnosis (DX) Narrative. S DIR(0)="9002080.01,85" S:ACHSRDXN]"" DIR("B")=ACHSRDXN D ^DIR G A1:$D(DUOUT),KDIR:$D(DTOUT) D KDIR S ACHSRDXN=$G(Y) ; RPX ; Enter Referral ICD PROCEDURE codes. I $D(ACHSRPX) F ACHS=1:1 Q:'$D(ACHSRPX(ACHS)) S ACHSRPX(ACHS)=$S(ACHSRPX(ACHS)["ICD":"ICD."_$P(^ICD0(+ACHSRPX(ACHS),0),U),1:"CPT."_$P(^ICPT(+ACHSRPX(ACHS),0),U)) S DIR(0)="9002080.186,.01" F ACHS=1:1 S DIR("A")=$P(^DD(9002080.186,.01,0),U)_" # "_ACHS_" " S:$D(ACHSRPX(ACHS)) DIR("B")=$P(ACHSRPX(ACHS),";") D ^DIR KILL DIR("B") Q:$D(DIRUT) S ACHSRPX(ACHS)=Y I $D(DUOUT)!(X="@") F %=ACHS:1 Q:'$D(ACHSRPX(%)) KILL ACHSRPX(%) G A1:$D(DUOUT),KDIR:$D(DTOUT) D KDIR ; RPXN ; Enter Referral Procedure (PX) Narrative. S DIR(0)="9002080.01,87" S:ACHSRPXN]"" DIR("B")=ACHSRPXN D ^DIR G A1:$D(DUOUT),KDIR:$D(DTOUT) D KDIR S ACHSRPXN=$G(Y) G ^ACHSA7 ; END ; G END^ACHSA ; KDIR ; KILL DIR,DIRUT W !! Q ; DISPMPC ;EP - From call to DIR, display medical priorities W !! S %=0 F S %=$O(^DD(9002080.01,81,21,%)) Q:'% W !,^(%,0) I $G(^DD(9002080.01,81,21,%+1,0))[" - " Q:'$$DIR^XBDIR("E","Press RETURN...") Q ; NODE ;EP - To set 0th node of Referral medical data multiples. ; Called from ^ACHSA7. Here because of size of ACHSA7. ; ACHSDIEN must be defined. I $D(ACHSRDX) S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)=$$ZEROTH^ACHS(9002080,100,84) I $D(ACHSRPX) S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)=$$ZEROTH^ACHS(9002080,100,86) Q ; ACHSACO1 ACHSACO1 ; IHS/ADC/GTH - AREA CONSOLIDATION (2/3) ; [ 11/18/1998 3:08 PM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**6**;SEP 17, 1997 ;;ACHS*3*4 PATCH TO PATCH #3 & HAS TO CORE CONVERSION ;;ACHS*3*6 FIX FORMAT OF CORE RECORDS ; A1 ; Initialize counters, main process loop. S ACHSCT=+^ACHSPCC("COUNT"),(ACHSCTV,ACHSCTFI,ACHSCTFS,ACHSCTPG,ACHSCTPD)=0 F ACHS=2:1:7 S ACHSTOTL(ACHS)=0 S:$D(^ACHSZOCT("BCBS")) ACHSCTFI=^("BCBS") S:$D(^ACHSZOCT("AOPD")) ACHSCTPD=^("AOPD") S:$D(^ACHSAOVU(0)) ACHSCTV=+$P(^(0),U) S:$D(^ACHSZOCT("PIG")) ACHSCTPG=^("PIG") S:$D(^ACHSPIG(0,0)) ACHSCTPG=^(0) S ACHSCCOR=$G(^ACHSCORE("COUNT")),ACHSCCOR("P")=$$AOP^ACHS(2,2) U IO(0) W !,"Transfering ",$P(ACHSXD2,U,7)," CHS Data Records..." S DX=$X,DY=$Y S ACHSCTVS=ACHSCTV+1 F U IO R X:300,ACHSX2:300 G END^ACHSACO2:$E(X)="*",TERR^ACHSACO2:'($E(ACHSX2)) D T S X=+$P($P(X,"(",2),")") I '(X#10) U IO(0) W X X IOXY ; T ; S ACHSRTYP=+$E(ACHSX2),ACHSTOTL(ACHSRTYP)=ACHSTOTL(ACHSRTYP)+1 S:'$D(ACHSZFAC(ACHSFCPT)) ACHSZFAC(ACHSFCPT)=0 S $P(ACHSZFAC(ACHSFCPT),U,1)=$P(ACHSZFAC(ACHSFCPT),U,1)+1 D T2:ACHSRTYP=2,T3:ACHSRTYP=3,T4:ACHSRTYP=4,T5:ACHSRTYP=5,T6:ACHSRTYP=6,T7:ACHSRTYP=7 F ACHSJ=2:1:7 S:ACHSTOTL(ACHSJ)>0 ACHSZFAC(ACHSFCPT,ACHSDRUN,ACHSJ)=ACHSTOTL(ACHSJ) Q ; T2 ; DHR records for HAS and/or CORE. ; For HAS ;I ACHSCCOR("P")'="CORE","BC"'[$E(ACHSX2,2) S ACHSCT=ACHSCT+1,^ACHSPCC(ACHSFACD,ACHSCT)=ACHSX2,ACHSCT=ACHSCT+1,^ACHSPCC(ACHSFACD,ACHSCT)=$J("",60)_$$REPEAT^XLFSTR("9",20),^ACHSPCC("COUNT")=ACHSCT ;ACHS*3*4 I ACHSCCOR("P")'="CORE" D ;ACHS*3*4 . N ACHSSRTY S ACHSSRTY=$S("BC"[$E(ACHSX2,2):$E(ACHSX2,2),1:"") . I ACHSSRTY="" S ACHSHR1=ACHSX2 ;ACHS*3*4 . I ACHSSRTY="B" S ACHSHR2=ACHSX2 ;ACHS*3*4 . I ACHSSRTY="C" D ;ACHS*3*4 .. S ACHSCT=ACHSCT+1 ;ACHS*3*4 .. S ^ACHSPCC(ACHSFACD,ACHSCT)=$$CORE(1) ;ACHS*3*4 .. S ACHSCT=ACHSCT+1 ;ACHS*3*4 .. S ^ACHSPCC(ACHSFACD,ACHSCT)=$$CORE(2) ;ACHS*3*4 . S ^ACHSPCC("COUNT")=ACHSCT ;ACHS*3*4 ; ; For CORE I ACHSCCOR("P")'="HAS" S ACHSCCOR=ACHSCCOR+1,^ACHSCORE(ACHSFACD,ACHSCCOR)=ACHSX2,^ACHSCORE("COUNT")=ACHSCCOR Q ; T3 ; Patient records for Area ofc and/or FI. Q:$$AOP^ACHS(2,3)'="Y"!('$D(^ACHSAOP(DUZ(2),20,ACHSFCPT))) S ACHSCTFI=ACHSCTFI+1,^ACHSBCBS(ACHSCTFI)=ACHSX2 Q ; T4 ; Vendor records for Area ofc and/or FI. G T4A:$$AOP^ACHS(2,3)'="Y"!('$D(^ACHSAOP(DUZ(2),20,ACHSFCPT))) S ACHSCTFI=ACHSCTFI+1,^ACHSBCBS(ACHSCTFI)=ACHSX2 T4A ; Q:$$AOP^ACHS(2,4)'="Y" S ACHSCTV=ACHSCTV+1,^ACHSAOVU(ACHSCTV)=ACHSX2 Q ; T5 ; Document records for Area ofc and/or FI. I $$AOP^ACHS(2,3)="Y",$D(^ACHSAOP(DUZ(2),20,ACHSFCPT)) S ACHSCTFI=ACHSCTFI+1,^ACHSBCBS(ACHSCTFI)=ACHSX2 D SVRSUB:$D(^ACHSAOP(DUZ(2),21)) Q ; T6 ; Payment record for Area ofc. Q:$$AOP^ACHS(2,4)'="Y" S ACHSCTPD=ACHSCTPD+1,^ACHSAOPD(ACHSCTPD)=ACHSX2 Q ; T7 ; Statistical records. S ACHSCTPG=ACHSCTPG+1 I $E(ACHSX2,1,2)="7A" S ACHSSTYP=$E(ACHSX2,3,4) S ^ACHSPIG(ACHSSTYP,ACHSFACD,ACHSCTPG)=ACHSX2 Q ; SVRSUB ; Generate ^ACHSSVR global from 5A & 5B records. G SVR5A:$E(ACHSX2,1,2)="5A",SVR5B:$E(ACHSX2,1,2)="5B" Q ; SVR5A ; KILL ACHSX3 S DIC="^AUTTVNDR(",DIC(0)="M",D="C",X=$E(ACHSX2,22,33) I $E(X,11,12)=" " S X=$E(X,1,10) D ^DIC Q:Y<1 Q:'$D(^ACHSAOP(DUZ(2),21,"B",+Y)) S ACHSX3=ACHSX2,ACHSZFAC=$E(ACHSX2,15,20),ACHSEIN=$E(ACHSX2,22,33) S:$E(ACHSEIN,11,12)=" " ACHSEIN=$E(ACHSEIN,1,10) S ACHSCTFS=ACHSCTFS+1 S ^ACHSSVR(ACHSEIN,ACHSZFAC,ACHSCTFS)=ACHSX3 Q ; SVR5B ; Q:'$D(ACHSX3) S ACHSX4=ACHSX2,^ACHSSVR(ACHSEIN,ACHSZFAC,ACHSCTFS)=ACHSX3_ACHSX4 Q ; REC(X) ;EP - Return the name of the export record, 1-7. Q:'$G(X) "" Q $P("NOT USED^DHR RECORDS FOR HAS/CORE^PATIENT RECORDS FOR AO/FI^VENDOR RECORDS FOR AO/FI^DOCUMENT RECORDS FOR AO/FI^PAYMENT RECORDS FOR AO^STATISTICAL RECORDS",U,X) ; ;BEGIN ACHS*3*4 CORE MODIFICATIONS ADDITIONAL CODE CORE(R) ;PROCESS A '2B' RECORD INTO THE 80-160 '2' PART TWO RECORD I R=1 D . S ACHSEIN=$E(ACHSX2,3,14) . ;S R=$E(ACHSHR1,1,60)_$E(ACHSEIN_$J("",15),1,15)_" " ;ACHS*3*6 . S R=$E(ACHSHR1,1,64)_$E(ACHSEIN_$J("",15),1,15)_" " ;ACHS*3*6 I R=2 D . S ACHSF12=$E(ACHSHR2,59,60) ;FISCAL YEAR . S ACHSF10=$E(ACHSHR2,61,64) ;BEGIN DATE . S ACHSF11=$E(ACHSHR2,65,68) ;END DATE . S R=$J("",45)_ACHSF10_ACHSF11_ACHSF12_$J("",25) . S R=$E(R,1,60)_$$REPEAT^XLFSTR("9",20) ;AHCS*3*6 REQUIRED BY HAS Q R ;END ACHS*3*4 CORE MODIFICATIONS ADDITIONAL CODE ACHSAD ACHSAD ; IHS/ADC/GTH - DISPLAY DOCUMENTS ; [ 09/17/97 9:12 AM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**2**;SEP 17, 1997 ;;ACHS*3*2 FIX CAPTIONED PRINT PROBLEM ; S ACHSVIEW="" F D ^ACHSUSC Q:$D(DUOUT)!$D(DTOUT)!'$D(ACHSDIEN)!$D(ACHSDVEW) KILL ACHSVIEW Q ; DUMP ;EP - From Option. ; KILL DR KILL DR,D0,D1,D2,ACHSDIEN ; ACHS*3*2 IHS/ADC/GTH 12-30-97 D ^ACHSUD G K:'$D(ACHSDIEN) DEV ; S %=$$PB^ACHS I %="^"!$D(DUOUT)!$D(DTOUT) D K Q I %="B" D DIQ^XBLM("^ACHSF("_DUZ(2)_",""D"",",ACHSDIEN),HOME^%ZIS Q S %ZIS="OPQ" D ^%ZIS I POP S IOP=$I D ^%ZIS G K G:'$D(IO("Q")) START K IO("Q") I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV S ZTRTN="START^ACHSAD",ZTDESC="DUMP OF DATA FROM DOCUMENT "_$$DOC^ACHS(0,14)_"-"_ACHSFC_"-"_$$DOC^ACHS(0,1) F ACHS="AC*","ACHS*" S ZTSAVE(ACHS)="" D ^%ZTLOAD G DEV:'$D(ZTSK) K ZTSK G K ; START ;EP - TaskMan. S:$D(IO("S")) IOSL=66 U IO S DIC="^ACHSF("_DUZ(2)_",""D"",",DA=ACHSDIEN D EN^DIQ I IO'=$G(ACHSIO) W @IOF K ; K ACHSDIEN,D0,D1 D ^%ZISC D ERPT^ACHS:$D(ZTQUEUED) D RTRN^ACHS Q ; ACHSAJ ACHSAJ ; IHS/ADC/GTH - ADJUST A PAID DOCUMENT (1/2) ; [ 11/18/1998 2:59 PM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**4**;SEP 17, 1997 ;;ACHS*3*3 FIX UNDEFINED "PA" NODE DURING EOBR PROCESSING ;;ACHS*3*4 PATCH FOR PATCH #3 & HAS TO CORE CONVERSION ; I $D(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0)),$P(^(0),U,2)=DT W !!,*7," The Register Has Been CLOSED." G ENDC^ACHSAJ1 ; A3 ; Select document, check for paid status. D ^ACHSUD G ENDC^ACHSAJ1:'$D(ACHSDIEN) I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) W !!,*7,?10,"NOT A PAID DOCUMENT -- ONLY PAID DOCUMENTS CAN BE ADJUSTED" G A3 S ACHSTIEN=1,ACHSIPA=0,ACHS3RDS="" KILL ACHSSIG D INIT^ACHSRP2,^ACHSAV S ACHSADJ="" D A0A^ACHSUSC A4 ; G ENDC^ACHSAJ1:'$D(ACHSDIEN) I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+") W !,"LOCK FAILED AT A4+2^ACHSAJ" G K^ACHSAJ1 A4A ;EP - Automatic adjustment. S ACHSX=+$$DOC^ACHS(0,14) D FYCVT^ACHSFU S ACHSACFY=ACHSY,ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY) S X=1 F S X=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X)) Q:X="" I $P(^(X,0),U,2)="P" S ACHSSVDT=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X,0),U,10) Q:ACHSSVDT>0 S ACHSTIEN=X D CKB^ACHSUUP I $D(ACHSISAO),$D(ACHSCNC) S ACHSERRE=13,ACHSEDAT="" D ^ACHSEOBG D K^ACHSAJ1 S ACHSERRA=1 Q G END^ACHSAJ1:$D(ACHSCNC) ;ACHS*3*3 FIX THE UNDEF ON THE "PA" NODE DURING EOBR PROCESSING ;S ACHSAPA=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U),ACHS3PA=$P(^("PA"),U,5),(ACHSTADJ,ACHSNADJ)=0 S (ACHSTADJ,ACHSNADJ)=0 ;ACHS*3*4 FIX UNDEFINED VARIABLE PROBLEM S ACHSAPA=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) ;ACHS*3*3 I ACHSAPA="" S ACHSERRE=12,ACHSEDAT=S,ACHSERRA=1 D ^ACHSEOBG D K^ACHSAJ1 Q ;ACHS*3*3 S ACHS3PA=$P(ACHSAPA,U,5),ACHSAPA=$P(ACHSAPA,U,1) ;ACHS*3*3 S:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")) ACHSAPA=$P(^("ZA"),U),ACHSTADJ=$P(^("ZA"),U,2),ACHSNADJ=$P(^("ZA"),U,3),ACHS3PA=$P(^("ZA"),U,4) I $D(ACHSISAO),$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"EB1",ACHSPDAT)) S ACHSERRE=29,ACHSEDAT="" D ^ACHSEOBG B2 ; I $D(ACHSISAO),$D(ACHSIPA) S Y=ACHSIPA,ACHSSIGN=1 S:$E(Y)="-" ACHSSIGN=-1,Y=$E(Y,2,99) G B3 I $D(ACHSISAO) S ACHSERRE=28,ACHSEDAT=ACHSIPA,ACHSERRA=1 D ^ACHSEOBG,K^ACHSAJ1 Q B2Z ; W !!,"Amount Of Adjustment: " S ACHSSIGN=1 D READ^ACHSFU G ENDC^ACHSAJ1:$D(DTOUT),ENDC^ACHSAJ1:$D(DUOUT) I Y?1"?".E W !," Enter Payment Adjustment Amount (e.g. + or - 150.00)." G B2 I Y=""!(+Y=0) W *7," NO AMOUNT ENTERED",!! G ENDC^ACHSAJ1 S:$E(Y)="+" Y=$E(Y,2,99) S:$E(Y)="-" ACHSSIGN=-1,Y=$E(Y,2,99) S:Y?1"$".E Y=$E(Y,2,99) F I=1:1 S F=$F(Y,",") Q:'F S Y=$E(Y,1,F-2)_$E(Y,F,99) I '(Y?1N.N1"."2N!(Y?1N.N))!($L(Y)>10) W *7," ??" G A4 B3 ; D OBLM^ACHSFU G:$D(DUOUT) B2 I $D(ACHSISAO),$D(ACHSERRE) S ACHSERRA=1,ACHSEDAT="" D ^ACHSEOBG,K^ACHSAJ1 Q C ; S (S,X)=ACHSSIGN*Y,X2="2$",X3=0 D COMMA^%DTC W:'$D(ACHSISAO) " (",X,")" S (ACHSESDO,ACHSAMT)=S S ACHS("CHK")=1,ACHSUFLG="" D SBAENT^ACHSUUP KILL ACHSUFLG I S>0 G C0 I -1*S>$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U) W:'$D(ACHSISAO) *7,!!,"NEG ADJ CANNOT BE > PAYMENT AMT" G:'$D(ACHSISAO) B2 I $D(ACHSISAO) S ACHSERRE=25,ACHSEDAT=S,ACHSERRA=1 D ^ACHSEOBG D K^ACHSAJ1 Q C0 ; I $D(ACHSISAO) G C1 S Y=$$DIR^XBDIR("D","Enter Date Document Paid","","","","",2) G B2:$D(DUOUT),ENDC^ACHSAJ1:$D(DTOUT) S ACHSEOBD=Y,ACHSPDAT=ACHSEOBD C01 ; W !! S ACHSJERR=0 I $$DOC^ACHS(0,17)="I" S ACHSPSQN=$G(^ACHSF(DUZ(2),"SEQN"))+1,^ACHSF(DUZ(2),"SEQN")=ACHSPSQN G C02 S Y=$$DIR^XBDIR("N","Enter Sequence Number From EOBR","","","","",2) G C0:$D(DUOUT),ENDC^ACHSAJ1:$D(DTOUT) S ACHSPSQN=Y C02 ; I '$D(ACHSISAO),$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"EB1",ACHSPDAT)) D G:ACHSJERR ENDC^ACHSAJ1 . W !!,*7,*7,"A Transaction Has Been Processed For This Document On This Date.",!!?15,$$FMTE^XLFDT(ACHSPDAT),!! . S Y=$$DIR^XBDIR("Y","Do You Wish To Continue","N") . I ('Y)!$D(DUOUT)!$D(DTOUT) S ACHSJERR=1 .Q S ACHSPIND="F" I $$DOC^ACHS(0,17)="I" G C1 ; C03 ; EOBR Services billed. D DIR("9002080.02,19^O",$$SET(9002080.02,19,$G(ACHSSV))) G ENDC^ACHSAJ1:$D(DTOUT),B2:$D(DUOUT) S ACHSSV=Y ; C04 ; EOBR Control Number. D DIR("9002080.02,16^O",$G(ACHSCTL)) G ENDC^ACHSAJ1:$D(DTOUT),C03:$D(DUOUT) S ACHSCTL=Y ; C05 ; EOBR Check number. D DIR("9002080.02,17^O",$G(ACHSCHK)) G ENDC^ACHSAJ1:$D(DTOUT),C04:$D(DUOUT) S ACHSCHK=Y ; C06 ; EOBR Remittance number. D DIR("9002080.02,18^O",$G(ACHSREM)) G ENDC^ACHSAJ1:$D(DTOUT),C05:$D(DUOUT) S ACHSREM=Y ; C07 ; EOBR Oblication type. D DIR("9002080.02,20^O",$$SET(9002080.02,20,$G(ACHSOB))) G ENDC^ACHSAJ1:$D(DTOUT),C06:$D(DUOUT) S ACHSOB=Y ; C1 ; Adjustment to 3rd party payment. I $D(ACHSISAO) S Y=$G(ACHS3RDP) G C1A D DIR("9002080.02,7^O",$G(ACHS3TAJ)) G ENDC^ACHSAJ1:$D(DTOUT),C07:$D(DUOUT) S ACHS3TAJ=Y C1A ; S ACHS3AJ=ACHS3PA+Y,ACHS3TAJ=Y OK ; Ask for confirmation. G D1^ACHSAJ1:$D(ACHSISAO) G D1^ACHSAJ1:$$DIR^XBDIR("Y","Is everything correct","NO","","","",2) G B2 ; DIR(ACHS,ACHS1) ; ( , ) W ! KILL DIR,DUOUT,DTOUT,DIRUT S DIR(0)=ACHS I $L($G(ACHS1)) S DIR("B")=ACHS1 D ^DIR KILL DIR Q ; SET(X,Y,Z) ; (File,Field,Internal) Return the external form of a set element. S %=$P(^DD(X,Y,0),U,3) F X=1:1 S Y=$P(%,";",X) Q:Y="" I $P(Y,":")=Z S Y=$P(Y,":",2) Q Q Y ; ACHSBMC ACHSBMC ; IHS/ADC/GTH - RCIS INTERFACE SUBROUTINES ; [ 09/17/97 9:12 AM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**3**;SEP 17, 1997 ;;ACHS*3*2 FIX THE CHS/RCIS POINTER PROBLEM ;;ACHS*3*3 FIX THE CHS/RCIS POINTER PROBLEM ; ; ----------------------------------------------------------- ; ADD ;EP - Allow user to link P.O. to referral, if not previously linked. I '$$LINK W !,"The link to the Referral system is not on." Q ADD1 ; D ^ACHSUD Q:'$D(ACHSDIEN) I $$DOC^ACHS(0,12)=4 W *7,!,"This document has been canceled." G ADD1 I $$DOC^ACHS(2,7) W *7,!,"This document is already linked to Referral ",$P(^BMCREF($$DOC^ACHS(2,7),0),U,2),"." G ADD1 NEW ACHS S ACHS="",ACHS("ADD")=1 ; This acts as a flag in GETREF(). ADD2 ; D GETREF(.ACHS) Q:$D(DUOUT)!$D(DTOUT)!(ACHS<1) I '($$DOC^ACHS(0,22)=DFN) D G ADD2 . W *7,!,"The patient in the Referral is '",$P(^DPT(DFN,0),U),"'." . W !,"The patient in the P.O. is '",$S($$DOC^ACHS(0,22):$P(^DPT($$DOC^ACHS(0,22),0),U),1:""),"'." .Q I '$$DIE^ACHS("62////"_ACHS) W *7,!,"Addition of Referral failed in routine ACHSBMC." D RTRN^ACHS Q S ACHSREF=ACHS D AUTH,DX,PX Q ; ; ----------------------------------------------------------- ; AUTH ;EP - Update the P.O. document status in the RCIS REFERRAL file. ; ; ACHSREF must contain the Referral IEN. ; ACHSDIEN must contain the P.O. IEN at the "D" level. ; I '$$LINK Q I $$DOC^ACHS(0,12)=4 D Q ; If P.O. is canceled, delete. . D AUTH^BMCCHS(ACHSREF,ACHSDIEN,"D") . I '$$DIE^ACHS("62///@") .Q NEW ACHS,ACHSTIEN S ACHS(.02)=$$DOC^ACHS(0,9) S ACHS(.03)=$$DOC^ACHS("ZA",1) I 'ACHS(.03) S ACHS(.03)=$$DOC^ACHS("PA",1) S ACHS(.04)="",ACHSTIEN=0 F S ACHSTIEN=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN)) Q:'(ACHSTIEN=+ACHSTIEN) I $$TRAN^ACHS(0,5)="F" S ACHS(.04)=1 Q S ACHSTIEN=0,ACHS(.06)=9999999,ACHS(.07)=0 F S ACHSTIEN=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSTIEN)) Q:'(ACHSTIEN=+ACHSTIEN) D . I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,2)ACHS(.07) S ACHS(.07)=$P(^(0),U,3) .Q I ACHS(.06)=9999999 KILL ACHS(.06) I ACHS(.07)=0 KILL ACHS(.07) S ACHS(.08)="0"_$$DOC^ACHS(0,14)_"-"_$$FC^ACHS(DUZ(2))_"-"_$$DOC^ACHS(0,1) S ACHS(.09)=$$DOC^ACHS(0,8) ; D AUTH^BMCCHS(ACHSREF,ACHSDIEN,"P",.ACHS) ;I '$$DIE^ACHS("62///"_ACHSREF) ;ACHS*3*3 FIX THE LINK TO RCIS I '$$DIE^ACHS("62////"_ACHSREF) ;ACHS*3*3 FIX THE LINK TO RCIS Q ; ; ----------------------------------------------------------- ; DX ;EP - Transfer DX info to RCIS. ; ACHSDIEN must contain the P.O. IEN at the "D" level. ; I '$$LINK Q NEW ACHS,ACHSDX S ACHS(.02)=$$DOC^ACHS(0,22) ; Patient DFN S ACHS(.03)=$$DOC^ACHS(2,7) ; Referral IEN S ACHS(.04)="F" S ACHS(.06)="" S ACHSDX=0 F S ACHSDX=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSDX)) Q:'(ACHSDX=+ACHSDX) D . S ACHS(.01)=+$P(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSDX,0),U) . ; The first DX on the EOBR is the primary DX. . S ACHS(.05)=$S(ACHSDX=1:"P",1:"S") . D DXA^BMCCHS(ACHS(.03),.ACHS) .Q Q ; ; ----------------------------------------------------------- ; GETREF(ACHS) ;EP - Ask user to select referral, and retieve info on same. I '$$LINK Q W ! NEW DIC,D ; In DIC("S"), the Referral must be [C]HS and [A]ctive. S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: " I $G(ACHS),$D(^BMCREF(ACHS)) D SET^BMCCHS(ACHS,.ACHS) S DIC("B")=$P(^DPT(ACHS(.03),0),U) GETREF1 ; D ^DIC I Y<1 D Q . Q:$D(DUOUT)!$D(DTOUT)!($G(ACHS("ADD"))) . NEW A,I,V . S Y=$P($G(^BMCPARM(DUZ(2),0)),U,24) . I Y,$$FMDIFF^XLFDT(DT,Y)<180,$$DIR^XBDIR("Y","Are you sure you want to enter a P.O. w/o a Referral","N","","","",1) KILL ACHS Q . W *7,!!,"You must have a CHS referral to enter a P.O.",!! . S DUOUT=$$DIR^XBDIR("E","Press RETURN...") Q .Q ; S ACHS=+Y D SET^BMCCHS(ACHS,.ACHS) I ($G(ACHS(.04))'="C")!($G(ACHS(.15))'="A") D G GETREF1 . W !!," This must be a Referral that is 'ACTIVE' and 'CHS FACILITY'." . W !,"You have selected a Referral that is '",$$EXTSET^XBFUNC(90001,.15,$G(ACHS(.15))),"' and '",$$EXTSET^XBFUNC(90001,.04,$G(ACHS(.04))),"'.",! . S ACHS=0 .Q S DFN=ACHS(.03),ACHSHRN=$$HRN^ACHS(DFN,DUZ(2)) S ACHSPROV=ACHS(.07) S %=ACHS(.14) I $L(%) S ACHSTYP=$S(%="I":1,%="O":3,1:"") I $G(ACHS(1105)) S ACHSEDOS=ACHS(1105) Q ; ; ----------------------------------------------------------- ; LINK() ;EP - Is link to RCIS on? Q +$P($G(^BMCPARM(DUZ(2),0)),U,4) ; ; ----------------------------------------------------------- ; P(I,S,P) ;EP - Return Internal format of Referral with IEN of I,S, Piece P. ; FOR USE DURING DEVELOPMENT. RCIS WILL PROVIDE REQUIRED DATA ; ITEMS. Q $P($G(^BMCREF(I,S)),U,P) ; ; ----------------------------------------------------------- ; PX ;EP - Transfer PX info to RCIS. ; ACHSDIEN must contain the P.O. IEN at the "D" level. ; I '$$LINK Q NEW ACHS,ACHSPX,ACHSPX1 S ACHS(.02)=$$DOC^ACHS(0,22) ; Patient DFN S ACHS(.03)=$$DOC^ACHS(2,7) ; Referral IEN S ACHS(.04)="F" S ACHS(.06)="" S ACHSPX=0 F S ACHSPX=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSPX)) Q:'(ACHSPX=+ACHSPX) D . S ACHS(.01)=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSPX,0),U) . Q:'(ACHS(.01)["ICPT(") . S ACHS(.01)=+ACHS(.01) . ; . ; The first PX on the EOBR is the primary PX. . I $G(ACHSPX1) S ACHS(.05)="S" . E S ACHS(.05)="P",ACHSPX1=1 . S ACHS(.07)=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSPX,0),U,4) . D PXA^BMCCHS(ACHS(.03),.ACHS) .Q Q ; ; ----------------------------------------------------------- ; STAT(S) ;EP - Update Referral status ; ACHSREF must contain the Referral IEN. I '$$LINK Q NEW ACHS S ACHS(1112)=S S ACHS(1113)=DT ; I S="D" S ACHS(1114)=$G(FRED) ; Figure out the denial reason. ; KILL S D STAT^BMCCHS(ACHSREF,"P",.ACHS) Q ; ; ----------------------------------------------------------- ; ACHSC6C ACHSC6C ; IHS/ADC/GTH - CALCULATE EXPENDITURE REPORT BY PATIENT/COMMUNITY ; [ 09/17/97 9:12 AM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**3**;SEP 17, 1997 ;;ACHS*3*3 FIX THE REPORT TOTALS ; ST ; D NOW^ACHS K ^TMP("ACHSC6",$J) Z ; S ACHSTRDT=ACHSBDT-1,(ACHST64,ACHST43,ACHST57)=0 Z1 ; S ACHSTRDT=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT)) G ^ACHSC6P:ACHSTRDT<1!(ACHSTRDT>ACHSEDT),Z1:'$D(^ACHSF(DUZ(2),"TB",ACHSTRDT,"I")) S DOC=0 Z2 ; S DOC=$O(^ACHSF(DUZ(2),"TB",ACHSTRDT,"I",DOC)) G Z1:DOC<1,Z2:'$D(^ACHSF(DUZ(2),"D",DOC,0)) S X=^(0),ACHSTY=$P(X,U,4) I ACHSRPT1<4,ACHSTY'=ACHSRPT1 G Z2 S DFN=$P(X,U,22) G Z2:DFN<1,Z2:'$D(^DPT(DFN,0)) S (ACHSTAO,ACHSP3B)=0 I $D(^ACHSF(DUZ(2),"D",DOC,"PA")),^("PA")>0 S ACHSTAO=+^("PA"),ACHS=0 F S ACHS=$O(^ACHSF(DUZ(2),"D",DOC,"T",ACHS)) Q:+ACHS=0 S ACHSP3B=ACHSP3B+$P(^(ACHS,0),U,8) I ACHSTAO<1 S ACHSTAO=$P(X,U,9) G Z2:+ACHSTAO=0 S ACHSTOS=$S(ACHSTY=1:43,ACHSTY=2:57,ACHSTY=3:64,1:"") S:ACHSTOS=64 ACHST64=ACHST64+ACHSTAO S:ACHSTOS=43 ACHST43=ACHST43+ACHSTAO S:ACHSTOS=57 ACHST57=ACHST57+ACHSTAO S ACHSESDA=$S($D(^ACHSF(DUZ(2),"D",DOC,1)):+^(1),1:0),ACHSNAME=$P(^DPT(DFN,0),U) COMM ; Community Of Residence. F ACHSCOMM=0:0 Q:'$O(^AUPNPAT(DFN,51,ACHSCOMM)) S ACHSCOMM=$O(^AUPNPAT(DFN,51,ACHSCOMM)) S ACHSCOMM=$S(ACHSCOMM:$P(^AUPNPAT(DFN,51,ACHSCOMM,0),U,3),1:"") S ACHSCOMN="" I ACHSCOMM,$D(^AUTTCOM(ACHSCOMM,0)) S ACHSCOMN=$P(^(0),U) I ACHSCOMN="",$D(^AUPNPAT(DFN,11)),$P(^(11),U,18)]"" S ACHSCOMN=$P(^(11),U,18) S:ACHSCOMN="" ACHSCOMN="UNKNOWN" I ACHSRPT=2 S ACHSNAME=ACHSCOMN I ACHSRPT=5 S ACHSNAME=$P($G(^AUPNPAT(DFN,11)),U,8),ACHSNAME=$S(ACHSNAME:$P(^AUTTTRI(ACHSNAME,0),U),1:"UNKNOWN") SET ; Set Work File. I '$D(^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS)) S ^(ACHSTOS)=DFN_U_ACHSCOMN_U_1_U_ACHSESDA_U_ACHSTAO_U_ACHSP3B G Z2 ;S A=$P(^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS),U,3)+1,B=$P(^(ACHSTOS),U,4)+ACHSESDA,C=$P(^(ACHSTOS),U,5)+ACHSTAO,D=$P(^(ACHSTOS),U,6)+ACHSP3B+$S(ACHSTOS=57:ACHSTAO,1:0),^(ACHSTOS)=DFN_U_ACHSCOMN_U_A_U_B_U_C_U_D S A=$P(^TMP("ACHSC6",$J,"P",ACHSNAME,ACHSTOS),U,3)+1,B=$P(^(ACHSTOS),U,4)+ACHSESDA,C=$P(^(ACHSTOS),U,5)+ACHSTAO,D=$P(^(ACHSTOS),U,6)+$S(ACHSTOS=57:ACHSTAO,1:0),^(ACHSTOS)=DFN_U_ACHSCOMN_U_A_U_B_U_C_U_D ;ACHS*3*3 FIX THE REPORT TOTALS G Z2 ; ACHSEOB ACHSEOB ; IHS/ADC/GTH - PROCESS EOBRS (1/6) - SELECT INPUT MEDIA ; [ 05/22/1998 2:12 PM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**3**;SEP 17, 1997 ; ACHS*3*3 IHS//DJM FIX ZTIO=IO PROBLEM ; I ACHSISAO G A3 I $D(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0)),+$P(^(0),U,2)>0 W *7,!?10,"CHS Registers are Closed -- EOBR Posting CANCELLED",! D RTRN^ACHS G ENDX A3 ; S ACHSPAR=$S(ACHSISAO=0:$$PARM^ACHS(2,14),ACHSISAO=1:$$AOP^ACHS(2,6)) A3A ; W !!,"Your PRINT EOBR parameter is: ",ACHSPAR,"." I ACHSPAR="Y" W ! S %ZIS("A")="Print EOBRs on what device:" D ^%ZIS I POP S IOP=$I D ^%ZIS G ENDX S ACHSEOIO=IO,ACHSPAR=$S('ACHSISAO:$$PARM^ACHS(2,15),ACHSISAO=1:"") W !!,"Your UPDATE DOCUMENT FROM EOBR parameter is : ",ACHSPAR,".",! S ACHSFCSQ=+$P(^ACHSF(DUZ(2),2),U,21) S0 ; I '$O(^ACHSEOBR("0"))!('ACHSISAO) G S1 W *7,!!,"The '^ACHSEOBR(' work global is about to be killed.",!!,"Are you sure previously processed EOBRs were sent to your facilities",!,"via the EOBR OUT Area option?" S Y=$$DIR^XBDIR("Y","","N") G ENDX:$D(DUOUT)!$D(DTOUT)!('Y) S1 ; W ! I ACHSISAO D REPORT^ACHSEOB0 G ENDX:$D(DUOUT)!$D(DTOUT)!$D(DIRUT),S2 S %ZIS="OPQ",%ZIS("A")="SELECT PRINTER FOR PROCESSING REPORT:" D ^%ZIS S:$D(IO("Q")) ACHSIO("Q")=IO("Q") I POP S IOP=$I D ^%ZIS G ENDX I ^%ZIS(1,IOS,"TYPE")="HFS",$L($G(IOPAR)) S ZTIO("IOPAR")=IOPAR ;S ACHSERPT="D",ZTIO=IO,IOP=$I ; ACHS*3*3 ZTIO=IO IS WRONG S ACHSERPT="D",ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,IOP=$I ; ACHS*3*3 REPLACE IO WITH ION;IOST;IOM;IOSL D ^%ZIS U IO S2 ; I ^%ZOSF("OS")["DSM" G DSM^ACHSEOBH I 'ACHSISAO S ACHSMEDY="F",ACHSMEDA="EB"_$$ASF^ACHS(DUZ(2))_"." G SUF S ACHSMEDY="F",ACHSAEND="" D ^ACHSEOBS G ABEND:ACHSAEND=1,ENDX:ACHSAEND=2 KILL ACHSAEND G CONT1 ; SUF ; D FACSRCH^ACHSEOBB U IO(0) I '$O(ACHSUFLS(0)) W !!,*7,"No EOBR Files Available for Processing",! D RTRN^ACHS G ENDX S Y=$$DIR^XBDIR("NO^1:"_$O(ACHSUFLS(9999),-1)_":3","Enter the Number of the Facility EOBR File you want to Process","","","","",1) G ENDX:$D(DUOUT)!($D(DIRUT))!('Y) I +$$PARM^ACHS(2,21)=0 G SEQOK I +$P(^ACHSF(DUZ(2),2),U,21)=999 S $P(^ACHSF(DUZ(2),2),U,21)=0 I $P(^ACHSF(DUZ(2),2),U,21)+1=+$P(ACHSUFLS(ACHSK(Y))," ",3) G SEQOK U IO(0) W !,*7,"Wrong Facility Sequence Selected for EOBR file ",! G ENDX:$$DIR^XBDIR("E"),SUF SEQOK ; S ACHSEOBD=$P(ACHSUFLS(ACHSK(Y))," ",2),ACHSSEQN=+$P(ACHSUFLS(ACHSK(Y))," ",3) SEQOK1 ; I '$D(^ACHSF(DUZ(2),17,"B",ACHSEOBD)) G CONT U IO(0) W *7,! I $$DIR^XBDIR("E","FI EOBR FILE has already been PROCESSED -- ENTER to Continue") D CLOSEALL^ACHS G SUF ; CONT ; S ACHSMEDA=$P(ACHSUFLS(ACHSK(Y))," ",1) S Y=$$DIR^XBDIR("Y","Process file '"_$$IM^ACHS_ACHSMEDA_"' (Y/N)","N","","","",1) G ENDX:+Y=0!($D(DUOUT))!($D(DIRUT))!($D(DTOUT)) CONT1 ; I 'ACHSISAO,$$PARM^ACHS(2,15)="Y",$$E^ACHSJCHK("ACHS") D G:'Y ENDX . U IO(0) . W !!!!,*7,$$C^XBFUNC("The compiled menu indicates CHS Users are Active -- EOBR'S CANNOT BE POSTED") . W !!,$$C^XBFUNC("You can Exercise the"),!,$$C^XBFUNC("'Clean old Job Nodes in XUTL'"),! . W $$C^XBFUNC("option (usually) on the site mgr's menu and try again."),!! . S DIR(0)="Y",DIR("A")="OR, if you're sure no CHS users are active, you can continue",DIR("B")="N",DIR("?")="You must enter 'Y' to continue." . D ^DIR . KILL DIR .Q S ^ACHSUSE("EOBR")="" KILL ^ACHSEOBR ; Work global. S ^ACHSEOBR("0")="",(ACHSCTR,ACHSCTR(1))=0 I $$OPEN^%ZISH($S(ACHSISAO:$$AOP^ACHS(2,1),1:$$IM^ACHS),ACHSMEDA,"R") S ACHSEMSG="M10" D ERROR^ACHSTCK1 G ENDX I 'ACHSISAO D SAVDCR("B") U IO(0) W ! RDHDR ;EP D ^ACHSEOB1 G:ACHSTERR ABEND I ACHSISAO D AREA^ACHSEOBB G XIT I 'ACHSISAO D FAC^ACHSEOBB,SAVDCR("E") XIT ; S ACHSRPT=2 I ACHSISAO S ACHSRPT=1 G ENDX:ACHSERPT="N" I ACHSERPT="S" D REPORT^ACHSEOBC G:ACHSERR ABEND D HOME^%ZIS U IO G ENDX I '$D(ACHSIO("Q")) S (ACHSEOIO,IOP)=ZTIO S:$L($G(ZTIO("IOPAR"))) %ZIS("IOPAR")=ZTIO("IOPAR") KILL ZTIO D ^%ZIS,START^ACHSEOB6,HOME^%ZIS U IO G ENDX S %DT="R",X="NOW" D ^%DT S ZTDTH=Y+.0002 S:$L($G(ZTIO("IOPAR"))) IOPAR=ZTIO("IOPAR") S ZTRTN="START^ACHSEOB6",ZTDESC="CHS EOBR Processing Report, for "_$P(^AUTTLOC(DUZ(2),0),U,2)_"." F %="ACHSRPT","ACHSEOBD","ACHSISAO" S ZTSAVE(%)="" D ^%ZTLOAD G:'$D(ZTSK) ABEND ENDX ;EP S IONOFF="" D CLOSEALL^ACHS,KILL^ACHSEOBB KILL DIR W !! D RTRN^ACHS Q ; ABEND ;EP G ENDX ; SAVDCR(S) ;EP - Save DCR amounts for EOB Summary Report ; S = "B" for begin values, "E" for end values. NEW Y S Y=0 F S Y=$O(ACHSFYWK(DUZ(2),Y)) Q:'Y S ^ACHSEOBR("DCR",Y,S)=^ACHS(9,DUZ(2),"FY",Y,"W",ACHSFYWK(DUZ(2),Y),1) Q ; ACHSEOB0 ACHSEOB0 ; IHS/ADC/GTH - CONTINUATION OF ACHSEOB ; [ 09/17/97 9:12 AM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**3**;SEP 17, 1997 ;;ACHS*3*3 FIX THE ZTIO=IO DEVICE SELECTION ERROR ; REPORT ;EP S ACHSERPT=$$DIR^XBDIR("S^N:NO REPORT;S:SUMMARY REPORT - Total # of EOBR's by Facility;D:DETAILED REPORT - Listing of each EOBR plus Summary Report","Enter Type Of Report To Print","SUMMARY") Q:$D(DUOUT)!$D(DTOUT)!(ACHSERPT="N") W !! KILL %ZIS S %ZIS="OP",%ZIS("A")="Enter Printer For Report:" D ^%ZIS KILL %ZIS S:$D(IO("Q")) ACHSIO("Q")=IO("Q") I POP S IOP=$I D ^%ZIS G ENDX^ACHSEOB ;S ZTIO=IO,IOP=$I S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL,IOP=$I ;ACHS*3*3 THIS CAUSES THE WRONG DEVICE TO BE SELECTED SOME TIME D ^%ZIS U IO Q ; ACHSPAP ACHSPAP ; IHS/ADC/GTH - LINK TO PATIENT CARE COMPONENT (1/2) ; [ 09/17/97 9:12 AM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**3**;SEP 17, 1997 ;;ACHS*3*3 ; ; This routine is not called unless the LINK is established to PCC. ; ; Required variables, that are unaltered: ; ACHSDOCR - Document record. ; ACHSDIEN - Document Internal Entry Number. ; S ACHS=$G(APCDALVR("APCDTYPE")) ; NEW ACHSDUZ0,ACHSLBL,ACHSTRAN,ACHSWOK,APCDALVR,AUPNTALK,APCDANE,APCDAUTO ; I $L(ACHS) S APCDALVR("APCDTYPE")=ACHS S ACHSWOK=(($G(ACHSISAO)'=0)&('$D(ZTQUEUED))) ; OK to write. ; I $P(ACHSDOCR,U,12)'=3 W:ACHSWOK !,"NOT A PAID DOCUMENT." Q I $P(ACHSDOCR,U,3) W:ACHSWOK !,"DOCUMENT NOT PATIENT SPECFIC (BLANKET OR SPECIAL LOCAL TRANS)." Q ; I ACHSWOK W !,"Transfering Medical data to PATIENT CARE COMPONENT!",! D WAIT^DICD ; I $$DOC^ACHS(2,5) D I '$$DIE^ACHS("60///@;61///@") W:ACHSWOK !,"DELETE VISIT from DOCUMENT record failed." Q . I $$TOK W !,"DELETING EXISTING VISIT INFO." . NEW APCDVDLT . S APCDVDLT=$$DOC^ACHS(2,5) . D ^APCDVDLT .Q ; F %=1:1 I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",%,0)),U,2)="P" S ACHSTRAN=^(0) Q S AUPNTALK=1,APCDANE=1,APCDAUTO=1,Y=$P(ACHSDOCR,U,22) D ^AUPNPAT ; S ACHSDUZ0=DUZ(0) S:'(DUZ(0)["M") DUZ(0)=DUZ(0)_"M" ; Requires SAC exception. ; F ACHSLBL="VISIT","VPOV","VPRV","PX","CHS","VDEN","VCPT" D @ACHSLBL Q:$D(APCDALVR("APCDAFLG")) S %=APCDALVR("APCDVSIT") KILL APCDALVR S APCDALVR("APCDVSIT")=% ; I $D(APCDALVR("APCDAFLG")) D . I $G(ACHSISAO)=0 S ACHSERRE=24,ACHSEDAT=$$FLG(APCDALVR("APCDAFLG")) D ^ACHSEOBG . NEW APCDVDLT . S APCDVDLT=$S($$DOC^ACHS(2,5):$$DOC^ACHS(2,5),1:$G(APCDALVR("APCDVSIT"))) . D:APCDVDLT ^APCDVDLT . I $$DOC^ACHS(2,5),$$DIE^ACHS("60///@;61///@") . Q:'ACHSWOK . W *7,!,"MEDICAL DATA FAILED TRANSFER TO PATIENT CARE COMPONENT.",!,$$FLG(APCDALVR("APCDAFLG")) . I $L($P(APCDALVR("APCDAFLG"),U,2)) W !,"VALUE = '",$P(APCDALVR("APCDAFLG"),U,2),"'" .Q ; S:1 DUZ(0)=ACHSDUZ0 Q ; ; --------------------------------------------------------------- ; VISIT ; Check/create VISIT entry in Patient Care Component. I $$TOK W !,"PCC VISIT..." ; S APCDALVR("APCDPAT")=$P(ACHSDOCR,U,22) S APCDALVR("APCDDATE")=$P(ACHSTRAN,U,10) S APCDALVR("APCDLOC")="`"_$$LOC($P(ACHSDOCR,U,4)) S:'$D(APCDALVR("APCDTYPE")) APCDALVR("APCDTYPE")="CONTRACT" S APCDALVR("APCDCAT")=$S($P(ACHSTRAN,U,16)="Y":"I",$P(ACHSDOCR,U,4)=1:"H",1:"A") ; S APCDALVR("APCDCLN")= ptr to CLINIC STOP file ; S APCDALVR("APCDACS")="" unknown ; S APCDALVR("APCDADD")="" D EN^APCDALV ; I $D(APCDALVR("APCDAFLG")) S APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"ADD to VISIT failed." Q ; I '$$DIE^ACHS("60////"_APCDALVR("APCDVSIT")),ACHSWOK W !,"Edit VISIT field of DOCUMENT failed." Q ; ; VPRV ; Create entry in V PROVIDER file. I $$TOK W !,"PCC PROVIDER..." ; S X=$O(^VA(200,"GIHS",215999,0)) I 'X S APCDALVR("APCDAFLG")=21 Q ; I '$P($G(^AUTTSITE(1,0)),U,22) S X=$P(^DIC(3,X,0),U,16) I 'X KILL X S APCDALVR("APCDAFLG")=22 Q ; S (DIE,DIC)=$S($P(^AUTTSITE(1,0),U,22):"^VA(200",1:"^DIC(16,"),DIC(0)="",X="`"_X X $P(^DD(9000010.06,.01,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=41 Q S APCDALVR("APCDTPRO")="`"_X ; S (X,APCDALVR("APCDPAT"))=$P(ACHSDOCR,U,22) X $P(^DD(9000010.06,.02,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=42 Q ; S (X,APCDALVR("APCDTPS"))="P" X $P(^DD(9000010.06,.04,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=44 Q ; S (X,APCDALVR("APCDTOA"))="" X $P(^DD(9000010.06,.05,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=45 Q ; S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]" ; D EN^APCDALVR ; I $D(APCDALVR("APCDAFLG")) S APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"ADD to V PROVIDER failed." Q ; Q ; ; VPOV ; Create entry in V POV file. I $$TOK W !,"PCC PURPOSE OF VISIT..." ; S APCDALVR("APCDTPS")="P" F ACHS=0:0 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHS)) Q:'ACHS!$D(APCDALVR("APCDAFLG")) S ACHS("DX")=+^(ACHS,0) I ACHS("DX")>1,$D(^ICD9(ACHS("DX"),0)),$E(^ICD9(ACHS("DX"),0))'="E" D VPOV1 KILL ACHS("DX") Q ; VPOV1 ; ; Pointer to ^ICD9( is in ACHS("DX"). ; S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]" ; ; .01 - POV - APCDTPOV S (DIE,DIC)="^ICD9(",DIC(0)="" S (X,APCDALVR("APCDTPOV"))="`"_ACHS("DX") X $P(^DD(9000010.07,.01,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=24_U_APCDALVR("APCDTPOV") Q ; ; .02 - Patient Name S APCDALVR("APCDPAT")=$P(ACHSDOCR,U,22) ; ; .04 - Provider Narrative - APCDTNQ S (DIE,DIC)="^AUTNPOV(",DIC(0)="" S (X,APCDALVR("APCDTNQ"))=^ICD9(ACHS("DX"),1) X $P(^DD(9000010.07,.04,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=14_U_APCDALVR("APCDTNQ") Q I $L(APCDALVR("APCDTNQ"))>74 S APCDALVR("APCDTNQ")=$E(APCDALVR("APCDTNQ"),1,74)_"~*CHS*" E S APCDALVR("APCDTNQ")=APCDALVR("APCDTNQ")_"*CHS*" ; ; .05 - Stage - APCDTSTG ; .06 - Modifier - APCDTMOD ; .07 - Cause of DX - APCDTCD ; .08 - First/Revisit - APCDTFR ; ; .09 - Cause of Injury - APCDTCI S X=$$DOC^ACHS(3,7) ;PATCH ACHS*3*3 THIS FIXES AN UNDEFINED ERROR IN EOBR PROCESSING ;I X S APCDALVR("ACPDTCI")=X,(DIE,DIC)="^ICD9(",DIC(0)="" X $P(^DD(9000010.07,.09,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=15_U_APCDALVR("APCDTCI") Q ;ACHS*3*3 I X S APCDALVR("APCDTCI")=X,(DIE,DIC)="^ICD9(",DIC(0)="" X $P(^DD(9000010.07,.09,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=15_U_APCDALVR("APCDTCI") Q ;ACHS*3*3 ; ; .11 - Place of Accident - APCDTPA ; .12 - Primary/Secondary - APCDTPS ; .13 - Date of Injury ; .14 - Override/Accept - APCDTACC ; .15 - Clinical Term ; .16 - Problem List Entry ; S APCDALVR("ACHSDIEN")="" ; Needed to get by X-NEW in APCDALVR, as a ; flag to V POV file to accept inactive ICD9 codes. ; D EN^APCDALVR ; I $D(APCDALVR("APCDAFLG")) S APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"ADD to V POV failed." ; KILL APCDALVR("APCDTPS") Q ; ; PX ; Create/update V PROCEDURE data. I $$TOK W !,"PCC PROCEDURE..." ; F ACHS=0:0 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHS)) Q:'ACHS!$D(APCDALVR("APCDAFLG")) S ACHS("PTR")=+^(ACHS,0),ACHS("PXDT")=$P(^(0),U,2),ACHS("PX")=$P(^ICD0(+^(0),0),U) D PX1 KILL ACHS("PTR"),ACHS("PXDT"),ACHS("PX") Q ; PX1 ; S APCDALVR("APCDATMP")="[APCDALVR 9000010.08 (ADD)]" S DIC(0)="M",X=$G(^DD(80.1,0,"DIC")) I X]"" X ^%ZOSF("TEST") E S DIC(0)="IM" I DFN S Y=DFN D ^AUPNPAT ; ; .01 - Procedure - APCDTPRC S (DIE,DIC)="^ICD0(" S (X,APCDALVR("APCDTPRC"))=ACHS("PX") X $P(^DD(9000010.08,.01,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=25_U_APCDALVR("APCDTPRC") Q ; ; .04 - Provider Narrative - APCDTNQ S (DIE,DIC)="^AUTNPOV(" S (X,APCDALVR("APCDTNQ"))=$P($G(^ICD0(ACHS("PTR"),1)),U) X $P(^DD(9000010.08,.04,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=35_U_APCDALVR("APCDTNQ") Q ; ; .06 - Procedure Date - APCDTPD S (X,APCDALVR("APCDTPD"))=ACHS("PXDT") X $P(^DD(9000010.08,.06,0),U,5,99) I '$D(X) S APCDALVR("APCDAFLG")=23_U_APCDALVR("APCDTPD") Q ; D EN^APCDALVR ; I $D(APCDALVR("APCDAFLG")) S APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"ADD to V PROCEDURE failed." Q ; Q ; VDEN ; Create entries in V DENTAL I $$TOK W !,"PCC V DENTAL..." D VDEN^ACHSPAP1 Q ; VCPT ; Create entries in V CPT I $$TOK W !,"PCC V CPT..." D VCPT^ACHSPAP1 Q ; CHS ; Create an entry in V CHS I $$TOK W !,"PCC V CHS..." D CHS^ACHSPAP1 Q ; TOK() ;EP - Change argument to 1 interactive testing. Q 0 ; LOC(T) ; ; Given the Type of service return the LOCATION IEN: ; TOS LOCATION Name ; ------------------------ ------------------------- ; 1 = Inpatient CHS HOSPITAL ; 2 = Dental CHS OTHER ; 3 = Outpatient CHS PHYSICIAN OFFICE ; If the above cannot be ascertained based on the ASUFAC of the ; facility, return DUZ(2). NEW A,Y S A=$P($G(^AUTTLOC(DUZ(2),0)),U,10) I 'A Q DUZ(2) S A=$E(A,1,4)_$S(T=1:"82",T=2:"97",1:"88") S Y=$O(^AUTTLOC("C",A,0)) I Y Q Y I T=2 S A=$E(A,1,4)_"86" S Y=$O(^AUTTLOC("C",A,0)) I Y Q Y Q DUZ(2) ; FLG(N) ; I '$G(N) Q "" I '$L($T(ERRS+N)) Q "" Q $P($T(ERRS+N),";",4) ERRS ; ;;1;Bad Input Template ;;2;DIE Interface Failed ;;3 ;;4 ;;5 ;;6 ;;7 ;;8 ;;9 ;;10 ;;11 ;;12 ;;13 ;;14;Provider Narrative failed edit in V POV ;;15;Cause Of Injury failed edit in V POV ;;16 ;;17 ;;18 ;;19 ;;20 ;;21;Cannot find generic contract provider for V PROVIDER ;;22;PROVIDER cannot be found in File 6 for V PROVIDER ;;23;PROCEDURE DATE failed edit in V PROCEDURE ;;24;ICD Diagnosis code failed edit in V POV ;;25;ICD Procedure code failed edit in V PROCEDURE ;;26;AUTHORIZATION NUMBER failed edit in V CHS ;;27;PAY STATUS failed edit in V CHS ;;28;TOTAL CHARGES failed edit in V CHS ;;29;DATE OF DISCHARGE failed edit in V CHS ;;30;NO OF VISITS failed edit in V CHS ;;31;ADA code failed edit in V DENTAL ;;32;CPT code failed edit in V CPT ;;33;Number Of Unites failed edit in V DENTAL ;;34;Tooth Surface failed edit in V DENTAL ;;35;PROVIDER NARRATIVE failed edit in V PROCEDURE ;;36 ;;37 ;;38 ;;39 ;;40 ;;41;Provider (.01) failed edit in V PROVIDER ;;42;Patient (.02) failed edit in V PROVIDER ;;43 ;;44;Primary/Secondary (.04) failed edit in V PROVIDER ;;45;Operator/Attending (.05) failed edit in V PROVIDER ;;46 ACHSPCC4 ACHSPCC4 ; IHS/ADC/GTH - CHS AREA SPLITOUT (4/5)(EOJ) ; [ 09/17/97 9:12 AM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**3**;SEP 17, 1997 ;;ACHS*3*3 UPDATE THE PCC JCL CARD ; END ;EP I $D(ACHSJFLG)!(ACHSFLG) G END1 S:$D(^ACHSPCC("COUNT")) ^ACHSZOCT=^ACHSPCC("COUNT") KILL ^ACHSPCC("COUNT") BKASK ; U IO(0) G END1:'$$DIR^XBDIR("Y","Do you want to backup CHS files for THIS Export to TAPE","N","","","",2) I $D(DTOUT)!$D(DUOUT) G END1 COPYZ ; KILL ACHSJFLG S ACHSRTCD=999,ACHSDTJL=$E(DT,2,3)_$$JDT^ACHS(DT,1),ACHSZDIR="/usr/spool/chsdata/",ACHSZFN="chs????."_ACHSDTJL,ACHSDTYP="C",ACHSEXFN="CHS TX FILES" D TARBKUP^ACHSARCH I ACHSRTCD=0 G END1 U IO(0) I '$$DIR^XBDIR("Y","Do you want to try BACKUP files to "_ACHSDNAM_" AGAIN?","Y","","","",2) S ACHSJFLG=1 U IO(0) W *7,!!,"WARNING ****** -- TX FILES HAVE NOT BEEN SAVED TO TAPE" G END U IO(0) W !!,*7,"Make sure an appropriate TAPE (Write Enabled) is in the ",ACHSDNAM," DRIVE",! S Y=$$DIR^XBDIR("E") G END1:Y=0,COPYZ:Y=1 END1 ; G END3:$D(ACHSJFLG)!$D(ACHSFLG),END3:'$D(ACHSDHRN) END2 ; I $D(^AFSHPARM(DUZ(2),0)),$P(^(0),U,5)["Y",ACHSZFN["chsdh",$P($G(^ACHSAOP(DUZ(2),2)),U,12)="Y" D . S %="TX" . Q:'$L($T(@%^AFSLODF)) . U IO(0) . W !,"Begin Posting to 1166 Open Document file..." . S AFSXPFN=ACHSZFN . D TX^AFSLODF ; Post 1166 open document file . KILL AFSXPFN . U IO(0) . W !,"End Posting to 1166 Open Document file..." .Q S ^ACHSPCC("ODF-POST")=$$HTFM^XLFDT($H) END3 ; D ^%ZISC END5 ; Kill vars, do *PCC5, quit. KILL ACHSAREA,ACHSAPN,ACHSPRN,ACHSPSWD,ACHSUID,AUOK,ACHSCT1,ACHSCT2,ACHSPFX,ACHSDESC,DX,DY,ACHSEFDT,ACHSFCT,ACHSGLBL,ACHSHASH KILL J,L,ACHSMED,N,R,ACHSREF,ACHSRR,ACHSSFX1,ACHSSUF,X1,ACHSXY KILL DIR,ACHSFIRN,ACHSQUIT,X,Y,DIC I $D(ACHSGCTR) D:ACHSGCTR=6 RTRN^ACHS,^ACHSPCC5 KILL ACHSGCTR KILL ACHSIO Q ; JOBABEND ;EP S ACHSFLG=1 W !!?10,"ABNORMAL END OF AO CHS SPLIT-OUT / EXPORT",! ENTRETRN ;EP W ! I $$DIR^XBDIR("E","ENTER TO CONTINUE") G END ; ERROR ; ENTRY POINT. U IO(0) W !,"AN ERROR HAS OCCURRED == PLEASE DO AGAIN" D ^%ZISC G END ; EXIT1 ;EP W !!?10,"JOB TERMINATED BY OPERATOR" G END ; PCCHJCL ;EP - Generate Head JCL for Parklawn Computer Center. S ACHSX="",X=ACHSX_"//"_ACHSUID_ACHSAPN_"DHR JOB (OFM,"_ACHSUID_ACHSAPN_",1,0),'"_ACHSAREA_"',CLASS=E" D PADWRITE^ACHSPCC3 S X=ACHSX_"/*PASS "_ACHSPSWD D PADWRITE^ACHSPCC3 S X=ACHSX_"/*ROUTE PRINT RMT"_ACHSPRN D PADWRITE^ACHSPCC3 ;S X=ACHSX_"//PROCLIB DD DSN=OFM.PROCLIB,DISP=SHR" ;ACHS*3*3 UPDATE PCC JCL CARD S X=ACHSX_"//ESYLIB JCLLIB ORDER=(OFM.PROCLIB)" ;ACHS*3*3 UPDATE PCC JCL CARD D PADWRITE^ACHSPCC3 S X=ACHSX_"//S1 EXEC HASRADAP,AP="_ACHSAPN D PADWRITE^ACHSPCC3 S X=ACHSX_"//HASRAD10.DHRIN DD *" D PADWRITE^ACHSPCC3 S X="1BATCH"_$E(DT,4,7)_$E(DT,2,3)_"Z3"_$J("",25)_ACHSPFX D PADWRITE^ACHSPCC3 S X="",$P(X,"9",21)="",X=$J("",60)_X D PADWRITE^ACHSPCC3 Q ; PCCTJCL ;EP - Generate Tail JCL for Parklawn Computer Center. S ACHSX="",X="4BATCH"_$E(DT,4,7)_$E(DT,2,3)_"Z3"_ACHSCT2_$J("",21)_ACHSPFX_$J("",9)_ACHSHASH D PADWRITE^ACHSPCC3 S X="",$P(X,"9",21)="",X=$J("",60)_X D PADWRITE^ACHSPCC3 Q:ACHSGCTR=2 S X=ACHSX_"/*" D PADWRITE^ACHSPCC3 S X=ACHSX_"//" D PADWRITE^ACHSPCC3 ;I $$AOP^ACHS(2,8)="Y" S X="/*" D PADWRITE^ACHSPCC3 Q ; FIHJCL ;EP - Generate Head JCL for Fiscal Intermediary. TEST1 ; S X="//IHS003 JOB (1103,SBSP),'PRODUCTION',CLASS=Q,MSGCLASS=H" D PADWRITE^ACHSPCC3 TEST2 ; S X="//STEP01 EXEC IHS003,AREA=RMT"_$E(1000+ACHSFIRN,2,4) D PADWRITE^ACHSPCC3 TEST3 ; S X="//STEP010.SYSUT1 DD *" D PADWRITE^ACHSPCC3 PROD1 S X="//IHS001 JOB (1103,SBSP),'PRODUCTION',CLASS=Q,MSGCLASS=H" D PADWRITE^ACHSPCC3 PROD2 S X="//STEP01 EXEC IHS001,AREA=RMT"_$E(1000+ACHSFIRN,2,4) D PADWRITE^ACHSPCC3 PROD3 S X="//STEP010.IHSODOC DD *" D PADWRITE^ACHSPCC3 ; REMOVE COMMENTS FROM PROD1-PROD3 AND SUBSTITUTE FOR TEST1-TEST3 ; THIS ENABLES BC/BS OF NM TO AUTOMATICALLY PROCESS YOUR DATA S X="1BATCH"_$E(DT,4,7)_$E(DT,2,3)_"Z3"_$J("",25)_ACHSPFX D PADWRITE^ACHSPCC3 Q ; FITJCL ;EP - Generate Tail JCL for Fiscal Intemediary. S X="/*" D PADWRITE^ACHSPCC3 Q ; DPSHJCL ;EP - Generate Head JCL for Data center. S X="* $$ JOB JNM=TRANTAPE,CLASS=A,DISP=H,PRI=1,USER='DTR,"_$P(^AUTTAREA($P(^AUTTLOC(DUZ(2),0),U,4),0),U,2)_",P,OPR'" D PADWRITE^ACHSPCC3 S X="* $$ LST LST=X'01B',REMOTE="_$P(^AUTTSITE(1,0),U,3)_",JSEP=0" D PADWRITE^ACHSPCC3 S X="* $$ SLI S.TRANTAPE" D PADWRITE^ACHSPCC3 S X="* $$ DATA NCRDATA" D PADWRITE^ACHSPCC3 Q ; DPSTJCL ;EP - Generate Tail JCL for Data center. F X="/*","/&","* $$ EOJ" D PADWRITE^ACHSPCC3 Q ; ACHSPRE ACHSPRE ; IHS/ADC/GTH - PREINIT, CHK RQMNTS, DEL PKG, ETC. ; [ 09/17/97 9:12 AM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**3**;SEP 17, 1997 ;;ACHS*3*3 PRE INSTALL DOES NOT WORK ON DOS BASED MACHINES ; I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY Q ; I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY Q ; D HOME^%ZIS,DT^DICRW S X=$P(^VA(200,DUZ,0),U) W !,$$C^XBFUNC("Hello, "_$P(X,",",2)_" "_$P(X,",")),!!,$$C^XBFUNC("Checking Environment for Version "_$P($T(+2),";",3)_" of "_$P($T(+2),";",4)_".") ; S X=$G(^DD("VERSION")) W !!,$$C^XBFUNC("Need at least FileMan 21.....FileMan "_X_" Present") I X<21 D SORRY Q ; S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XU",0)),"VERSION")) W !!,$$C^XBFUNC("Need at least Kernel 7.1.....Kernel "_X_" Present") I X<7.1 D SORRY Q ; W !!,$$C^XBFUNC("Need HFS interface to Kernel (^%ZISH)....."_$J("",25)),!?20 S ACHS=1 ;ACHS*3*3 PRE INSTALL DOES NOT WORK ON DOS BASED MACHINES ;SET ACHSRCHK TO LOOK IN %ZISH OR ZISHMSMD BASED ON CONTENT OF ^%ZOSF("OS") S ACHSRCHK="'$L($T(@X"_$S($G(^%ZOSF("OS"))["UNIX":"^%ZISH",1:"ZISHMSMD")_"))" ;F X="OPEN","DEL","SEND","LIST","STATUS" W X," " I '$L($T(@X^%ZISH)) W !,$$C^XBFUNC($J("",30)_X_"^%ZISH not Present") S ACHS=0 F X="OPEN","DEL","SEND","LIST","STATUS" W X," " I @ACHSRCHK W !,$$C^XBFUNC($J("",30)_X_"^%ZISH not Present") S ACHS=0 I 'ACHS D SORRY Q W !,$$C^XBFUNC($J("",37)_"5 Entry Points OK") ; S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XB",0)),"VERSION")) W !!,$$C^XBFUNC("Need XB/ZIB, v 3.0.....XB/ZIB "_X_" Present") I X<3 D SORRY Q ; S X=$T(+2^AUPNPAT) S X=$S($P(X,";",3)>92.2:"Looks OK",$P(X,";",5)[3:"Looks OK",1:"") W !!,$$C^XBFUNC("Need AUPN, at least v 93.2 thru Patch 3....."_X) I '$L(X) D SORRY Q ; KILL ^TMP("ACHSPOST",$J) ; S X="ACHS",Y="ACHR" I '$D(^DIC(19,"C",X)),'($E($O(^DIC(19,"B",Y)),1,4)=X),'($E($O(^DIC(19.1,"B",Y)),1,4)=X) W !!,$$C^XBFUNC("NEW INSTALL."),! S ^TMP("ACHSPOST",$J,"NEW INSTALL")=1 Q ; I '$D(^DIC(9.4,"C","ACHS")) G ENVOK VERSION ; NEW DA,DIC S X="ACHS",DIC="^DIC(9.4,",DIC(0)="",D="C" D IX^DIC I Y<0 D Q . W !!,$$C^XBFUNC("You Have More Than One Entry In The") . W !,$$C^XBFUNC("PACKAGE File with an ""ACHS"" prefix.") . W !,$$C^XBFUNC("One entry needs to be deleted.") . W !,$$C^XBFUNC("Please FIX IT! Before Proceeding."),! . D SORRY .Q ; S DA=+Y W !!,$$C^XBFUNC("CHS version '"_$G(^DIC(9.4,DA,"VERSION"))_"' currently installed") ; S %=$G(^DIC(9.4,DA,"VERSION")) I %,%<1.5 D Q . W !,$$C^XBFUNC("This Version of Contract Health Management Cannot Be Installed Unless") . W !,$$C^XBFUNC("Version 1.5 Or Higher Has Been Previously Installed.") . W !,$$C^XBFUNC("A postinit to 1.5 converts dd numbers.") . D SORRY . I $$DIR^XBDIR("E","Press RETURN...") .Q ; ENVOK ; If this is just an environ check, end here. W !!,$$C^XBFUNC("ENVIRONMENT OK.") I '$D(DIFQ),'$$DIR^XBDIR("E","","","","","",1) KILL DIFQ,^TMP("ACHSPOST",$J) Q E I '$D(DIFQ) Q ; V168 ; I $G(DA),$G(^DIC(9.4,DA,"VERSION"))=1.68 S ^TMP("ACHSPOST",$J,1.68)="" W $$C^XBFUNC("You currently have version 1.68 installed."),$$C^XBFUNC("Don't forget to run ^ACHSYPOS to update medical priorities.") ; PKDEL ; Delete current CHS tmplts, optns, help frms, bultns, funcs. ; ; S XBPKNSP="ACHS" ; D START^XBPKDEL ; I '$D(DIFQ) W !,$$C^XBFUNC("I really need to re-arrange your menus."),!,$$C^XBFUNC("Please re-start the init.") KILL ^TMP("ACHSPOST",$J) Q ; W !,$$C^XBFUNC("Package deleted."),!,$$C^XBFUNC("Now to install the new one..."),! I $D(DIFQ),'$$DIR^XBDIR("E","","","","","",2) KILL DIFQ Q ; SORRY ; KILL DIFQ W *7,!,$$C^XBFUNC("Sorry....") Q ; ACHSRP2 ACHSRP2 ; IHS/ADC/GTH - PRINT CHS FORMS - INIT NAMED VARS, CALL FORM ROUTINE ; [ 11/18/1998 3:03 PM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**4**;SEP 17, 1997 ;;ACHS*3*3 FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM ;;ACHS*3*4 PATCH FOR PATCH #3 & HAS TO CORE CONVERSION ; D INIT,REF:($$PARM^ACHS(2,16)="Y")&(ACHSTYP'=2) G END:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0))!'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)) ; I $$PARM^ACHS(2,16)="Y" D ^ACHSRPU I $$PARM^ACHS(2,16)'="Y" D ^ACHSRP3:'(ACHSTYPV=2),^ACHSRP3D:(ACHSTYPV=2) ; ; To revert to the old Dental form (57), comment out the above two ; lines, and un-comment the following two lines. GTH 04-21-97 ; ; I ACHSTYPV'=2 D ^ACHSRP3:$$PARM^ACHS(2,16)'="Y",^ACHSRPU:$$PARM^ACHS(2,16)="Y" ; I ACHSTYPV=2 D ^ACHSRP3D ; I $D(ACHSRPNT) K ^TMP("ACHSRR",$J,DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN) G END LOCK +^ACHS(7,ACHS7DA):60 S X=^ACHS(7,ACHS7DA,"D",0),N=$P(X,U,3)+1,M=$P(X,U,4)+1,^ACHS(7,ACHS7DA,"D",N,0)=ACHSORDN_U_DUZ(2)_U_ACHSDIEN_U_ACHSTIEN S ^ACHS(7,ACHS7DA,"D","B",ACHSORDN,N)="",^ACHS(7,ACHS7DA,"D",0)=$P(X,U,1,2)_U_N_U_M,^ACHS(7,"P",DUZ(2),ACHSDIEN,ACHSTIEN,ACHS7DA,N)="" LOCK -^ACHS(7,ACHS7DA):60 KILL ^ACHSF("PQ",DUZ(2),ACHSTYPV,ACHSDIEN,ACHSTIEN) END ; KILL A,C,D,E,F,I,R,N,ACHSIPRM Q ; INIT ;EP - Initialize local vars to existing document data. Q:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0))!'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)) S X=^ACHSF(DUZ(2),"D",ACHSDIEN,0),Y=^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),ACHSCONP=$P(X,U,5),ACHSCAN=$P(X,U,6),ACHSSCC=$P(X,U,7),ACHSOBJC=$P(X,U,10) S ACHSPROV=$P(X,U,8),S=$P(X,U,14),ACHSTYP=$P(X,U,4),ACHSCOPT=$P(X,U,13),ACHSODT=$P(X,U,2),ACHSDEST=$P(X,U,17) S ACHSAGRP=$P(X,U,23),ACHSORDN=S_"-"_ACHSFC_"-"_$P(X,U),ACHSREFT=$E($P(Y,U,11)_$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,3)),U,10)) KILL ACHSBLKF I $P(X,U,3) S ACHSBLKF="",ACHSBLT=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"BT")) I $P(Y,U,10) S ACHSDOS=$P(Y,U,10) S ACHSSIG=$P($G(^ACHSF(DUZ(2),"P")),U,ACHSTYP),ACHSESDO=$P(Y,U,4),DFN=$P(Y,U,3),(ACHSEDOS,ACHSFDT,ACHSTDT)="" I ACHSTYP,$D(^ACHSF(DUZ(2),"D",ACHSDIEN,3)) S ACHSFDT=$P(^(3),U),ACHSTDT=$P(^(3),U,2),ACHSEDOS=$P(^(3),U,9) S:ACHSEDOS="" ACHSEDOS=ACHSFDT S ACHSESDA=$S((ACHSTYP=1)&($D(^ACHSF(DUZ(2),"D",ACHSDIEN,1))):$P(^(1),U),1:"") S ACHSHON=$S((ACHSTYP=3)&($D(^ACHSF(DUZ(2),"D",ACHSDIEN,2))):$P(^(2),U),1:"") S ACHSDES=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,1)),U,2) I ACHSDES]"" S A(7)=ACHSDES I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"BT")) S ACHSBLT=^("BT"),ACHSBLKF="" D PRT^ACHSUDF Q ; REF ; Set Referral Physician and Medical Priority into print vars. Q:$D(ACHSBLKF) S (ACHSDX,ACHSPX,X,N)="" ;I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,3)) S R(1)=$P(^(3),U,5),R(2)=$P(^(3),U,6) S:+R(1)>0 R(1)=$P(^DIC(16,$P(^DIC(6,R(1),0),U),0),U) I R(2),R(2)["I" S R(2)=$P($T(@R(2)),";;",2) ;ACHS*3*3 FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM ;S ACHS200=$S($G(^DD(9002080.01,50,0))["VA(200,":1,1:0) ;ACHS*3*3 FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM S ACHS200=$S($G(^DD(9002080.01,80,0))["VA(200,":1,1:0) ;ACHS*3*4 FIX REF TO LOOK AT 80 INSTEAD OF 50 I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,3)) D ;ACHS*3*3 FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM . S R(1)=$P(^(3),U,5),R(2)=$P(^(3),U,6) ;ACHS*3*3 FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM . I ACHS200 S:R(1)>0 R(1)=$P(^VA(200,R(1),0),U) ;ACHS*3*3 FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM . I 'ACHS200 S:+R(1)>0 R(1)=$P(^DIC(16,$P(^DIC(6,R(1),0),U),0),U) ;ACHS*3*3 FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM . I R(2),R(2)["I" S R(2)=$P($T(@R(2)),";;",2) ;ACHS*3*3 FIX THE REFERRAL PHYSICIAN DISPLAY PROBLEM PROC ; Set Referral Procedure Narrative into print vars for regular Form. I $$PARM^ACHS(2,16)="Y" G PROC1 G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,7)) DIAG S ACHSPX=^(7) I $L(ACHSPX)>190 S R("P",1)=$E(ACHSPX,1,22),N=23 I $L(ACHSPX)<190 S R("P",1)="",N=1 F X=2:1:5 S R("P",X)=$E(ACHSPX,N,N+37),N=N+38 DIAG ; Set Referral Diagnosis Narrative into print vars for regular Form. G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,5)) EXT S ACHSDX=^(5) I $L(ACHSDX)>148 S R("D",1)=$E(ACHSDX,1,22),N=23 I $L(ACHSDX)<148 S R("D",1)="",N=1 F X=2:1:4 S R("D",X)=$E(ACHSDX,N,N+36),N=N+37 EXT ; KILL ACHSDX,ACHSPX,X,N Q ; REFCOD ; I ;;Emergent/Acutely Urg II ;;Preventive Sevices III ;;Prim/Sec Services IV ;;Chr Tert/Exten Svc PROC1 ; Set Referral Procedure Narrative into print vars for Universal Form. G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,7)) DIAG S ACHSPX=^(7) I $L(ACHSPX)>118 S R("P",1)=$E(ACHSPX,1,22),N=23 I $L(ACHSPX)<118 S R("P",1)="",N=1 F X=2:1:4 S R("P",X)=$E(ACHSPX,N,N+36),N=N+37 DIAG1 ; Set Referral Diagnosis Narrative into print vars for Universal Form. G:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,5)) EXT S ACHSDX=^(5) I $L(ACHSDX)>72 S R("D",1)=$E(ACHSDX,1,22),N=23 I $L(ACHSDX)<72 S R("D",1)="",N=1 F X=2:1:3 S R("D",X)=$E(ACHSDX,N,N+36),N=N+37 EXT1 ; KILL ACHSDX,ACHSPX,X,N Q ; ACHSRP3 ACHSRP3 ; IHS/ADC/GTH - PRINT CHS (43 & 64) FORMS (1/2) ; [ 11/20/97 1:24 PM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**1**;SEP 17, 1997 ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. ; S T=0,E(8)=ACHSCOPT,ACHSSF="",LS=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,6),ACHSLCA=$P(^(0),U,7),ACHSTYPE=$P(^(0),U,2) S:+LS>0 ACHSSF="S"_LS S:+ACHSLCA>0 ACHSSF="C"_ACHSLCA I ACHSTYPE="S" S E(11)=E(7),X=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U),E(7)=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3) D KILLNULS TESTPRNT ;EP. (For test print.) PONUM ; W:'T ! W !?ACHSTAB+53,$S($$PARM^ACHS(2,20)="Y":$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+60+$S(ACHSTYPV=1:2,1:0),"0",ACHSORDN,ACHSSF DCR ; I $$PARM^ACHS(2,18)="Y" W " (",ACHSDCR,")" ORDOFF ; W !!?ACHSTAB+42+T,B(1) FACHRN ; W ! W:$D(A(1)) ?ACHSTAB,A(1) ORDADRS1 ; W:$D(B(2)) ?ACHSTAB+42+T,B(2) NAME ; W ! W:$D(A(2)) ?ACHSTAB,A(2) SSV ; I $G(DFN) S X=$$SSV^ACHSTX3(DFN) I "PVX"[X W ?ACHSTAB+28,X ORDADRS2 ; W:$D(B(3)) ?ACHSTAB+42+T,B(3) SUCODE ; W:$D(B(4)) ?69,"(",B(4),")" PATADRS ; W ! W:$D(A(3)) ?ACHSTAB,A(3) AGESEX ; W !?ACHSTAB W:$D(A(4)) A(4)," " COMCODE ; W:$D(A(5)) A(5) PROVIDER ; W:$D(D(1)) ?ACHSTAB+42+T,D(1) PROADRS1 ; W ! W:$D(D(2)) ?ACHSTAB+42+T,D(2) W ! DOS ; W:$D(A(6)) ?ACHSTAB,A(6) PROADRS2 ; W:$D(D(3)) ?ACHSTAB+42+T,D(3) FROMTO ; W ! W:$D(C(4)) ?ACHSTAB,C(4) PTYPE ; I $$PARM^ACHS(2,17)="Y",$D(D(7)) W ?ACHSTAB+39+T,D(7) EIN ; W:$D(D(4)) ?ACHSTAB+42+T,D(4) DESC ; W ! W:$D(A(7)) ?ACHSTAB,A(7) S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11) I F(6)'["Open Market",'$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(F(6),1,3)) S F(6)=ACHSARCO_"-"_F(6) CNTCANOB ; ; W ! ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. W !?ACHSTAB,"SCC: ",$G(F(8)) ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. S:T T=2 F I=6,7,9 W ?ACHSTAB+$P("^^^^^42^58^^67",U,I)+T,F(I) I T S T=T-1 W !!!?ACHSTAB,ACHSSIG S T=$S(ACHSTYPV=1:"32^41^62^70",1:"32^41^52^62") DTOPTAMT ; F I=7:1:9 W:$D(E(I)) ?ACHSTAB+$P(T,U,I-6),E(I) I I=8,ACHSTYPV=1 W ?ACHSTAB+54,ACHSESDA HSPORDNO ; W:$D(E(10)) ?ACHSTAB+$P(T,U,4),E(10) W !!!!!!!!!!! S I=$O(^ACHS(4,0)) G CSUPL:ACHSDEST'="F",CSUPL:'I,CSUPL:'$D(^ACHS(4,I,0)) W ?20,"PLEASE MAIL IHS-",$S(ACHSTYPV=1:"43",ACHSTYPV=3:"64",1:"")," AND COMPLETED HCFA-",$S(ACHSTYPV=1:"1450",ACHSTYPV=3:"1500",1:"")," TO:",!!?25,$P(^ACHS(4,I,0),U) W:$P(^(0),U,6)]"" !?25,$P(^(0),U,6) W !?25,$P(^ACHS(4,I,0),U,2),!?25,$P(^(0),U,3) W ", ",$P(^DIC(5,$P(^ACHS(4,I,0),U,4),0),U,2)," ",$P(^ACHS(4,I,0),U,5) CSUPL ; I ACHSTYPE="C"!(ACHSTYPE="S") D CSUPLA G END G END:$D(ACHSTPRT)!'$D(A(9)) D ^ACHSRP31 END ; W @IOF Q ; CSUPLA ;EP. S ACHSTYPE="******** "_$S(ACHSTYPE="C":"CANCELLATION ********",1:"SUPPLEMENT TO P.O. DATED "_E(11)) W !! F I=1:1:5 W ?25,ACHSTYPE,! I I=4,ACHSTYPE["CANCEL" S ACHSTYPE="CANCELLATION DATE "_$$FMTE^XLFDT($$TRAN^ACHS(0,1)) Q ; KILLNULS ;EP. F ACHSX="A","B","C","D","E","F" F ACHSY=1:1:12 S ACHS=ACHSX_"("_ACHSY_")" I $D(@ACHS),'$L(@ACHS) K @ACHS KILL ACHSX,ACHSY Q ; ACHSRP3D ACHSRP3D ; IHS/ADC/GTH - PRINT CHS (57 - DENTAL) FORMS ; [ 12/18/97 2:41 PM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**1**;SEP 17, 1997 ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. ; S ACHSSF="",LS=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,6),ACHSLCA=$P(^(0),U,7),ACHSTYPE=$P(^(0),U,2) S:LS ACHSSF="S"_LS S:ACHSLCA ACHSSF="C"_ACHSLCA I ACHSTYPE="S" S E(11)=E(7),X=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U),E(7)=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3) D KILLNULS^ACHSRP3 TESTPRNT ;EP. F I=1:1:ACHSTOPM W ! FACHRN ; W ! W:$D(A(1)) ?ACHSTAB,$E(A(1),1,28) FROMTO ; W:$D(C(4)) ?ACHSTAB+38,C(4) PONUM ; W ?ACHSTAB+54,$S($$PARM^ACHS(2,20)="Y":$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+62,"0",ACHSORDN,ACHSSF NAME ; W ! W:$D(A(2)) ?ACHSTAB,A(2) DCR ; I $$PARM^ACHS(2,18)="Y" W ?ACHSTAB+67,"(",ACHSDCR,")" PTADRS ; W ! W:$D(A(3)) ?ACHSTAB,A(3) SIG ; W ?ACHSTAB+37,ACHSSIG DT ; W ?ACHSTAB+64,E(7) DOBSEX ; W !?ACHSTAB W:$D(A(4)) A(4) COMCODE ; W:$D(A(5)) " ",A(5) ORDOFF ; W !?ACHSTAB+37,$E(B(1),1,25) SUCODE ; W ?ACHSTAB+64,B(4) AGESEX ; W !?ACHSTAB+2 W:$D(A(4)) $E(A(4),1,8),?ACHSTAB+26,$E(A(4),11) ORDADRS ; W:$D(B(3)) ?ACHSTAB+37,B(3) DEST ; W:$D(D(5)) ?ACHSTAB+64,D(5) SSV ; W ! I $G(DFN) S X=$$SSV^ACHSTX3(DFN) I "PVX"[X W ?ACHSTAB+11,X SSN ; W !?ACHSTAB+11 W:$D(A(11)) A(11) PROV ; W ?ACHSTAB+37,$E(D(1),1,23) PTYPE ; I $$PARM^ACHS(2,17)="Y",$D(D(7)) W $S($X<60:" ",1:""),D(7) EIN ; I $D(D(4)) S D(4)=$P(D(4)," ",1) W ?ACHSTAB+62,D(4) PADRS ; W:$D(D(2)) !?ACHSTAB+48,$E(D(2),1,30) W:$D(D(3)) !?ACHSTAB+48,$E(D(3),1,30) CANOBJ ; ; W !?10,$S('$D(ACHSTPRT):$P(^ACHS(2,ACHSCAN,0),U)_" "_$P(^ACHS(3,DUZ(2),1,ACHSSCC,0),U),1:"J123456 99.9Z") ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. W !?10,$S('$D(ACHSTPRT):F(7)_" "_F(9)_" SCC: "_F(8),1:"J123456 99.9Z") ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. DESC ; W ! W:$D(A(7)) ?ACHSTAB,A(7) CONTNO ; W ! W:$D(F(6)) ?19,F(6) OBLGAMT ; W ?ACHSTAB+38,E(9) I $D(ACHSTPRT) G END REFTYPE ; W !!!!!! S ACHSLREF=$E($P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,11)_$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,3)),U,10)) I $L(ACHSLREF) F I=3:1:7 W !?ACHSTAB+18,$P($T(@ACHSLREF),";",I) I ACHSTYPE="C"!(ACHSTYPE="S") W !!!!!!! D CSUPLA^ACHSRP3 G END F Q:$Y=44 W ! MCR ; G NO3:'$D(A(9)),MCD:'$D(^AUPNMCR(DFN,0)),MCD:'$P(^(0),U,3) W !?ACHSTAB+15,"MCR:",$P(^AUPNMCR(DFN,0),U,3) I $P(^(0),U,4),$D(^AUTTMCS($P(^AUPNMCR(DFN,0),U,4),0)) W $P(^(0),U) S J=0 F I=0:0 S I=$O(^AUPNMCR(DFN,11,I)) Q:+I'=I S:I>J J=I I J W ":",$P(^AUPNMCR(DFN,11,J,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7) MCD ; G RRE:'$D(^AUPNMCD("B",DFN)) F R=0:0 S R=$O(^AUPNMCD("B",DFN,R)) Q:'R S X=R W !?ACHSTAB+$S($Y=45:15,1:0),"MCD:",$P(^AUPNMCD(X,0),U,3) I $P(^(0),U,4),$D(^DIC(5,$P(^(0),U,4),0)) W $P(^(0),U,2) S J=0 F I=0:0 S I=$O(^AUPNMCD(X,11,I)) Q:+I'=I S:I>J J=I I J W ":",$P(^AUPNMCD(X,11,J,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7) RRE ; G PVT:'$D(^AUPNRRE(DFN,0)) W:$Y=44 ! W ?$S($Y=45:ACHSTAB+15,$X'>ACHSTAB:ACHSTAB,1:$X+5),"RRR:" W:$P(^AUPNRRE(DFN,0),U,3) $P(^AUTTRRP($P(^(0),U,3),0),U) W $P(^AUPNRRE(DFN,0),U,4) S J=0 F S J=$O(^AUPNRRE(DFN,11,J)) Q:J'?1N.N D . W ":",$P(^AUPNRRE(DFN,11,J,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7) .Q W ! PVT ; G NO3:'$D(^AUPNPRVT(DFN,11)),NO3:'$O(^(11,0)) W:$Y=44 ! F I=0:0 S I=$O(^AUPNPRVT(DFN,11,I)) Q:'I W ?ACHSTAB+$S($Y=45:15,1:0),$E($P(^AUTNINS($P(^(I,0),U),0),U),1,8),":",$P(^AUPNPRVT(DFN,11,I,0),U,2),":",$P(^(0),U,3),":",$E($P(^(0),U,6),2,7),":",$E($P(^(0),U,7),2,7)," " W:$X>50 ! NO3 ; W:$Y=44 !?ACHSTAB+15,"THIRD PARTY RESOURCES: NONE" END ; W @IOF KILL ACHSLREF Q ; G ;;GENERAL REFERRAL: Before providing services other than;examination, radiographs, or emergency services, this;claim form must be returned for predetermination. E ;;SPECIFIC REFERRAL, TYPE E: Emergency examination and;treatment not to exceed above obligation. Services;limited to Levels I-III of the IHS Schedule of Oral;Health Services. B ;;SPECIFIC REFERRAL, TYPE B: Examination and treatment;limited to Levels I-III of the IHS Schedule of Oral;Health Services. Treatment plans exceeding $300 must;be returned for predetermination. S ;;SPECIFIC REFERRAL, TYPE S: Specialty Services: Services;limited to *_____________, not to exceed above obligation.;;*In the above blank, give a brief description of the;services ordered, including ADA code(s), if possible. L ;;REFERRAL TYPE L: Authorization for dental laboratory;services for fabrication of _________________________. ACHSRPU ACHSRPU ; IHS/ADC/GTH - PRINT UNIVERSAL 843 FORMS ; [ 11/20/97 1:44 PM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**1**;SEP 17, 1997 ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. ; ; Print info from PDO onto Universal PDO form (IHS-843). ; S E(8)=ACHSCOPT,ACHSSF="",ACHSTYPE=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,2),ACHSLCA=$P(^(0),U,7),%=$P(^(0),U,6) S:+%>0 ACHSSF="S"_% S:+ACHSLCA>0 ACHSSF="C"_ACHSLCA I ACHSTYPE="S" S E(11)=E(7),X=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U),E(7)=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3) D KILLNULS^ACHSRP3 TESTPRNT ;EP. (For test print.) W !!!!!!!! I '$D(ACHSTPRT),"CS"[ACHSTYPE W "******** ",$S(ACHSTYPE="C":"CANCELLATION ********",1:"SUPPLEMENT TO P.O. DATED "_E(11)) INS ; S ACHSIPRM="N" D:'$D(ACHSTPRT) FORMAT S N="",X=0,ACHSBZD=0 PONUM ; -- Field 1 : DCR #, Document type, PDO number. W:$$PARM^ACHS(2,18)="Y" ?ACHSTAB+50,"DCR:",ACHSDCR W ?ACHSTAB+57,$S($$PARM^ACHS(2,20)="Y":$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+61,"0",ACHSORDN,ACHSSF NAME ; -- Field 2 : Patient Identification. W !! I $D(ACHSBLKF) W !?ACHSTAB,"** BLANKET **" D G ORDFAC . F %=1:1:7 W ! W:$D(A(%)) ?ACHSTAB,A(%) .Q I $D(A(2)) W ?ACHSTAB,A(2) INSHLD ; -- Field 3.a. : Name of Policy Holder. I ACHSIPRM="Y" S N=$O(I("P",N)),ACHSIPRM=N W ?ACHSTAB+55,$E(I(N,1),1,22) PATADRS ; -- Field 1 : Patient Identification. W ! I $D(A(3)) W ?ACHSTAB,A(3) INSNM ; -- Field 3.b. : Plan Name. I N'="" W:$D(I(N,2)) ?ACHSTAB+49,$E(I(N,2),1,29) SSN ; -- Field 1 : Patient Identification, SSN. W ! I $D(A(11)) W ?ACHSTAB,A(11) INSADRS ; -- Field 3.c. : Insurer's address. I N'="" W:$D(I(N,3)) ?ACHSTAB+48,I(N,3) SSV ; W ! I $G(DFN) S X=$$SSV^ACHSTX3(DFN) I "PVX"[X W ?ACHSTAB,X ; -- Insurer's addrs, cont. I N'="" W:$D(I(N,4)) ?ACHSTAB+48,I(N,4) INSPOL ; -- Field 3.d. : Insurer's Policy Number. W ! I N'="" W:$D(I(N,5)) ?ACHSTAB+52,I(N,5) FACHRN ; W ! I $D(A(1)) W ?ACHSTAB,$E(A(1),1,27) INSTYP ; -- Field 3.e. : Insurer's Coverage Type. I N'="" W:$D(I(N,6)) ?ACHSTAB+52,I(N,6) AGESEX ; W ! I $D(A(4)) W ?ACHSTAB,A(4) COMCODE ; I $D(A(5)) W " ",A(5) INSBDT ; -- Field 3.f. : Insurer's Effective Date. W ! I N'="",$D(I(N,7)) W ?ACHSTAB+53,$$FMTE^XLFDT(I(N,7)) DESC ; W !?ACHSTAB,"Desc: " I '$D(ACHSBLKF),$D(A(7)) W ?ACHSTAB+6,A(7) INSEDT ; I N'="",$D(I(N,8)) W ?ACHSTAB+53,$$FMTE^XLFDT(I(N,8)) S N="" ORDFAC ; W !!?ACHSTAB,B(1) W:$D(B(4)) ?ACHSTAB+25,"(",B(4),")" INSOTH1 ; S N=$O(I("B",N)) S:N=ACHSIPRM N=$O(I("B",N)) W:(N'="") ?ACHSTAB+38,$P(I("B",N),U) ORDADRS1 ; W ! W:$D(B(2)) ?ACHSTAB,B(2) INSOTH2 ; I N'="" W ?ACHSTAB+39,$P(I("B",N),U,2) ORDADRS2 ; W ! W:$D(B(3)) ?ACHSTAB,B(3) INSOTH3 ; I N'="" S N=$O(I("B",N)) I N'="" W ?ACHSTAB+38,$P(I("B",N),U),!,?ACHSTAB+39,$P(I("B",N),U,2),! S ACHSBZD=ACHSBZD+1 W:ACHSBZD=0 !! W:ACHSTYPV=1 ?ACHSTAB+11,"X" W:ACHSTYPV=2 ?ACHSTAB+19,"X" W:ACHSTYPV=3 ?ACHSTAB+35,"X" INSOTH5 ; I N'="" S N=$O(I("B",N)) I N'="" W ?ACHSTAB+38,$P(I("B",N),U),!,?ACHSTAB+39,$P(I("B",N),U,2),! S ACHSBZD=ACHSBZD+1 OPT ; ;W:$D(E(8)) ?ACHSTAB+57,E(8) ;COMMENTS AMT ; W:ACHSBZD'=2 !! W ! W:$D(E(9)) ?ACHSTAB+3,E(9) CONT ; ;W:$D(F(6)) ?ACHSTAB+57,F(6) ;CONTRACT CAN ; W:$D(F(7)) ?ACHSTAB+32,F(7) OBJ ; W:$D(F(9)) ?ACHSTAB+62,F(9) FROMTO ; W !! W:$D(C(5)) ?ACHSTAB+20,C(5) W:$D(R("D",1)) ?ACHSTAB+54,R("D",1) REF ; W ! W:$D(C(6)) ?ACHSTAB+20,C(6) W:$D(R("D",2)) ?ACHSTAB+39,R("D",2) W ! W:$D(R("P",1)) ?ACHSTAB+15,R("P",1) W ?ACHSTAB+27,"SCC: ",$G(F(8)) ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed. W:$D(R("D",3)) ?ACHSTAB+39,R("D",3) W ! W:$D(R("P",2)) ?ACHSTAB,R("P",2) W:$D(R(1)) ?ACHSTAB+55,R(1) W ! W:$D(R("P",3)) ?ACHSTAB,R("P",3) W ! W:$D(R("P",4)) ?ACHSTAB,R("P",4) W:$D(R(2)) ?ACHSTAB+55,R(2) W !!! RATE ; I $D(D(10)) W ?ACHSTAB+D(10)-1,"X" ;dmh chg to +D(10)-1 instead of +D(10) 11-27-96 ;W:'$D(D(9)) ?ACHSTAB+49,"OPEN MARKET" ;W:$D(D(9)) ?ACHSTAB+49,D(9) I $D(F(6)),F(6)="Open Market" W ?ACHSTAB+49,F(6) G SKIP I $D(D(9)),'$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(D(9),1,3)) S D(9)=ACHSARCO_"-"_D(9) W:$D(D(9)) ?ACHSTAB+49,D(9) SKIP ; W ! W:$D(D(11)) ?ACHSTAB+25,D(11) W !! W:$D(D(12)) ?ACHSTAB+D(12),"X" W:$D(D(13)) ?ACHSTAB+52,D(13) W ! W:$D(D(15)) ?ACHSTAB+52,D(15) SIG ; W !!?ACHSTAB,ACHSSIG,?ACHSTAB+66,E(7) PROVIDER ; W !!!!! W:$D(D(1)) ?ACHSTAB+7,D(1) PROTELE ; W:$D(D(6)) ?ACHSTAB+53,D(6) PROADRS1 ; W ! W:$D(D(2)) ?ACHSTAB+7,D(2) EIN ; W:$D(D(4)) ?ACHSTAB+47,D(4) PROADRS2 ; W ! W:$D(D(3)) ?ACHSTAB+7,D(3) UPIN ; W:$D(D(8)) ?ACHSTAB+47,D(8) PROTYPE ; ;I $$PARM^ACHS(2,17)="Y",$D(D(7)) W ?ACHSTAB+9,D(7) PROCLAS ; I $D(D(14)) W !! W:D(14)?1N.N ?ACHSTAB+D(14),"X" W !!!!!! S I=$O(^ACHS(4,0)) W:ACHSDEST="F" ?ACHSTAB+44,$P(^ACHS(4,I,0),U),!,?ACHSTAB,$P(^(0),U,2)," ",$P(^(0),U,3),",",$P(^DIC(5,$P(^ACHS(4,I,0),U,4),0),U,2)," ",$P(^ACHS(4,I,0),U,5) W:ACHSDEST="I" ?ACHSTAB+44,B(1),!,?ACHSTAB,B(2)," ",B(3) W @IOF KILL ; KILL A,B,C,D,E,F,I,N,R,X Q ; FORMAT ; PVT ; Q:DFN="" S (DA,N)=0 G MCR:'$D(^AUPNPRVT(DFN,11)) PVT1 ; F S DA=$O(^AUPNPRVT(DFN,11,DA)) Q:'DA D . S N=N+1,ACHSINS=^AUPNPRVT(DFN,11,DA,0) . D DINAPI . I ACHSBZD("OK")="N" S N=N-1 Q . S I(N,1)=$P(ACHSINS,U,4),I(N,2)=$P(ACHSINS,U),I(N,5)=$P(ACHSINS,U,2),I(N,6)=$P(ACHSINS,U,3),I(N,7)=$P(ACHSINS,U,6),I(N,8)=$P(ACHSINS,U,7) . S ACHSINS1=$P(^AUTNINS(I(N,2),0),U),I(N,2)=$P(ACHSINS1,U),I(N,3)=$P(ACHSINS1,U,2) . I $P(ACHSINS1,U,4),$D(^DIC(5,$P(ACHSINS1,U,4),0)) S X=$P(^(0),U,2),I(N,4)=$P(ACHSINS1,U,3)_", "_X_" "_$P(ACHSINS1,U,5) . I I(N,6)'="" S I(N,6)=$P(^AUTTPIC(I(N,6),0),U) . I (ACHSIPRM="N"),((I(N,8)'I(N,8)) ; -- ACHSBZD("DT") gets set from DINACK . I ACHSIPRM="N" S ACHSIPRM="Y",I("P",N)="" Q . S I(N,7)=$$FMTE^XLFDT(I(N,7)) . S I(N,8)=$$FMTE^XLFDT(I(N,8)) . S I("B",N)=$E(I(ACHSMR,2),1,(37-$L(I(ACHSMR,5))-$L(I(N,6))))_" "_I(ACHSMR,5)_" "_I(N,6)_"^EFF:"_I(N,7)_" "_I(N,8) . K:N'=ACHSMR I(N) . S N=N+1 ;dina moved this to here instead of at SET+3 1/15/97 .Q Q ; DINACK(ACHSINSZ) ; ;-- Check for eligibility at Date Of Service. Else, no print. ;-- ACHSINSZ contains the name of the insurance global. ; S ACHSBZD("OK")="N" Q:'$D(C(5)) S X=C(5),%DT="" D ^%DT S ACHSBZD("DT")=Y,ACHSBZD("I")=0 F S ACHSBZD("I")=$O(@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"))) Q:ACHSBZD("I")="" D Q:ACHSBZD("OK")="Y" . S ACHSBZD("REC")=@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"),0) . S ACHSBZD("B")=$P(ACHSBZD("REC"),U),ACHSBZD("E")=$P(ACHSBZD("REC"),U,2) . I (ACHSBZD("DT")'ACHSBZD("E")) S ACHSBZD("OK")="Y" Q . I (ACHSBZD("DT")'ACHSBZD("E")) S ACHSBZD("OK")="Y" Q I (ACHSBZD("DT")'$P(^(0),U,2) S ACHSEDT=$P(^(0),U,2) G S11 ; S2 ;EP - For export Re-Generation. G ERR:ACHSEDT=0 S ACHSFDT=ACHSBDT,ACHSLDAT=ACHSEDT,ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10) I $$PARM^ACHS(2,25)="Y" S X=$P(^ACHSF(DUZ(2),0),U,12) G AFACERR:+X<1 S ACHSAFAC=$P(^AUTTLOC(X,0),U,10) I +ACHSAFAC<1 G AFACERR I $$PARM^ACHS(2,9)="Y" F ACHS="252F","254V" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0)) I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" F ACHS="252G","252R","254D","254L","254M" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0)) S3 ; S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT)) G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT) S:ACHSRCT=0 ACHSFDT=ACHSBDT S ACHSTY="" S4 ; S ACHSTY=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY)) G S3:ACHSTY="",S4:ACHSTY="ZA"!(ACHSTY="IP") S P=0 S5 ; S P=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P)) G S4:P<1,S5:$P(^ACHSF(DUZ(2),"D",P,0),U,3)=2 S DA=0 S6 ; S DA=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTY,P,DA)) G S5:DA<1 S ACHSDEST=$P(^ACHSF(DUZ(2),"D",P,0),U,17),ACHSCTY=ACHSTY G S6:'$D(^ACHSF(DUZ(2),"D",P,"T",DA,0)) S X=$P(^(0),U,4),X=$P(X,".",1)_$E($P(X,".",2)_"00",1,2),ACHSIPA=$E(X+1000000000000,2,13) I ACHSCTY="C" S ACHSCTY=$P(^(0),U,5) G S6:'$D(^ACHSF(DUZ(2),"D",P,0)) S ACHSDOCR=^(0),ACHSTOS=$P(ACHSDOCR,U,4) S ACHSDR3=$G(^ACHSF(DUZ(2),"D",P,3),"") ;ACHS*3*4 I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S7 S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(P,DA)="" S ACHSPROV=$P(^ACHSF(DUZ(2),"D",P,0),U,8) S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST S7 ; I ACHSDEST="F"!(ACHSTY'="P") G S8 I $$PARM^ACHS(2,9)'="Y" G S7A S ^ACHSTXPG(ACHSTOS,P,DA)="" S7A ; I ACHSF638'="Y" G S8 S:'$P(ACHSDOCR,U,3) ^ACHSTXPG(ACHSTOS,P,DA)="" G S6 S8 ; G S6:ACHSTY="P" I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S6 S ^ACHSTXOB(P,DA)="" I +$P(ACHSDOCR,U,22),+$P(ACHSDOCR,U,20),+$P(ACHSDOCR,U,21) S ^ACHSTXPT(+$P(ACHSDOCR,U,22),+$P(ACHSDOCR,U,20),+$P(ACHSDOCR,U,21))=ACHSDEST S (ACHSX,X1)=$P(ACHSDOCR,U,14) D FYCVT^ACHSFU S ACHSXLOC=ACHSFC S:ACHSY<1987 ACHSXLOC="0"_$E(ACHSFC,2,3) S ACHSEFDT=$E(DT,4,5)_$E(DT,6,7)_$E(DT,2,3),ACHSCDE=$S(ACHSCTY="I":"05013",ACHSCTY="F":"05024",ACHSCTY="P":"05025",ACHSTY="S":"05015",1:""),ACHSDOCN=0_X1_ACHSXLOC_$P(ACHSDOCR,U),ACHSPROV=$P(ACHSDOCR,U,8) S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST G ERROR^ACHSTX:ACHSCDE="" D CANOBJ^ACHSTX8 S ACHSFED=$S($P(^AUTTVNDR(ACHSPROV,11),U,10)=2:2,1:1),ACHSRCT=ACHSRCT+1,ACHSRTYP(2)=ACHSRTYP(2)+1 S ^ACHSDATA(ACHSRCT)="2"_ACHSEFDT_ACHSCDE_$S(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_ACHSDOCN_$J("",13)_"1"_X1_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_$J("",16) I $L(^ACHSDATA(ACHSRCT))'=80 W !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 80 CHARACTERS IN LENGTH:",!!,^(ACHSRCT),!,*7,*7 G ERROR^ACHSTX I ACHSRCT=1 S ACHSFDT=ACHSBDT W !!,"NUMBER OF RECORDS PROCESSED = ",!! I ACHSRCT#25=0 W $J(ACHSRCT,8) D BC G S6 ; ERR ; W !!,*7,*7,"DCR REGISTER ERROR YOU MUST CLOSE YOUR REGISTERS FIRST" D ^%ZISC,KILL^ACHSTX8,RTRN^ACHS Q ; AFACERR ; W !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR - JOB CANCELLED" D ^%ZISC,KILL^ACHSTX8 Q ; CVTEND1 ; S ACHSROUT=ACHSRCT S:ACHSRCT>2 ACHSROUT=ACHSRCT KILL ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSOBJC,ACHSTOS,DA,ACHSTY,X1,ACHSXLOC G ^ACHSTX3 ; BC ;EP - Generate Export records 2B and 2C for CORE. ; ; 2B S ACHSCAN="IHS/AP:"_$E(ACHSCAN,2,3)_"/SU:"_$E(ACHSCAN,4)_"/YR:"_$E(ACHSCAN,5)_"/CC:"_$E(ACHSCAN,6,7) S ACHSCAN=ACHSCAN_$J("",30-$L(ACHSCAN)) ; S ACHSOBJC=$E($P($G(^ACHSOCC($P(ACHSDOCR,U,10),0)),U,2),1,20) S ACHSOBJC=ACHSOBJC_$J("",20-$L(ACHSOBJC)) ; S ACHSX=$P(ACHSDOCR,U,14) ;ACHS*3*4 THE FOLLOWING 2 LINES ARE Y2K COMPLIANT S ACHSABD=$E($P(ACHSDR3,U,1),4,7) ;ACHS*3*4 S ACHSAED=$E($P(ACHSDR3,U,2),4,7) ;ACHS*3*4 D FYCVT^ACHSFU ;S %="2B"_ACHSFC_"."_ACHSCAN_ACHSOBJC_ACHSY ;ACHS*3*4 S %="2B"_ACHSFC_"."_ACHSCAN_ACHSOBJC_ACHSY_ACHSABD_ACHSAED ;ACHS*3*4 D SET(%) ; ; 2C ; Vendor EIN S %=$E($P(^AUTTVNDR(ACHSPROV,11),U)_$J("",10),1,10)_$E($P(^AUTTVNDR(ACHSPROV,11),U,2)_" ",1,2) ; ; Vendor Name S %=%_$E($P(^AUTTVNDR(ACHSPROV,0),U),1,30) S %=%_$J("",42-$L(%)) ; ; Vendor CityStZip S %=%_$P(^AUTTVNDR(ACHSPROV,13),U,2)_","_$P(^DIC(5,$P(^AUTTVNDR(ACHSPROV,13),U,3),0),U,2)_","_$P(^AUTTVNDR(ACHSPROV,13),U,4) S %=$E(%,1,72),%=%_$J("",72-$L(%)) ; S %="2C"_% D SET(%) ; Q ; SET(%) ; S %=%_$J("",80-$L(%)) S ACHSRCT=ACHSRCT+1,^ACHSDATA(ACHSRCT)=% I ACHSRCT#25=0 W $J(ACHSRCT,8) Q ; ACHSTXA1 ACHSTXA1 ; IHS/ADC/GTH - EXPORT DATA - RECORD 2(DHR), SPECIFIC RE-EXPORTS ; [ 09/17/97 9:12 AM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**3**;SEP 17, 1997 ;;ACHS*3*3 SENDING SCC AS OCC, SHOULD MATCH ACHSTX2 ; ; This routine was created from ACHSTX2, for use with exporting ; specifically selected document transactions. If any change in logic ; is made to ACHSTX2, the change should also be made to this routine. ; D LINES^ACHSFU W @IOF,!,$$REPEAT^XLFSTR("*",80),!,$$C^XBFUNC("RE-EXPORT SELECTED CHS DATA"),!,$$REPEAT^XLFSTR("*"),! S ACHSCHSS="" D ^ACHSUF KILL ACHSCHSS D KILLGLBS^ACHSTX S (J,ACHSDCR,ACHSEDT,ACHSBDT)=0,ACHSRR="",ACHSF638=$$PARM^ACHS(0,8) F ACHS=2:1:7 S ACHSRTYP(ACHS)=0 W !?10,"FACILITY NAME: ",$$LOC^ACHS S ACHSBDT=0,ACHSEDT=3990000 S2 ; G ERR:ACHSEDT=0 S ACHSFDT=ACHSBDT S ACHSAFAC=$P(^AUTTLOC(DUZ(2),0),U,10) I $$PARM^ACHS(2,25)="Y" S X=$$PARM^ACHS(0,12) G AFACERR:+X<1 S ACHSAFAC=$P(^AUTTLOC(X,0),U,10) I +ACHSAFAC<1 G AFACERR I $$PARM^ACHS(2,9)="Y" F ACHS="252F","254V" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0)) I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" F ACHS="252G","252R","254D","254L","254M" S ACHS(ACHS)=$O(^ACHS(3,DUZ(2),1,"B",ACHS,0)) S3 ; S ACHSBDT=$O(^TMP("ACHSTXAR",$J,ACHSBDT)) G CVTEND1:ACHSBDT<1!(ACHSBDT>ACHSEDT) S ACHSLDAT=ACHSBDT S ACHSDIEN="" S4 ; S ACHSDIEN=$O(^TMP("ACHSTXAR",$J,ACHSBDT,ACHSDIEN)) G S3:ACHSDIEN="" G S4:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) S ACHSDOCR=^(0) G S4:$P(ACHSDOCR,U,3)=2 S ACHSTOS=$P(ACHSDOCR,U,4) S ACHSTIEN=0 S5 ; S ACHSTIEN=$O(^TMP("ACHSTXAR",$J,ACHSBDT,ACHSDIEN,ACHSTIEN)) G S4:ACHSTIEN<1 G S5:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)) S ACHSTRNR=^(0) S ACHSTY=$P(ACHSTRNR,U,2) G S5:ACHSTY="ZA"!(ACHSTY="IP") S ACHSDEST=$P(ACHSDOCR,U,17),ACHSCTY=ACHSTY ; S X=$P(ACHSTRNR,U,4),X=$P(X,".",1)_$E($P(X,".",2)_"00",1,2),ACHSIPA=$E(X+1000000000000,2,13) I ACHSCTY="C" S ACHSCTY=$P(ACHSTRNR,U,5) I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S7 S:ACHSTY="P"&(ACHSDEST'="F") ^ACHSTXPD(ACHSDIEN,ACHSTIEN)="" S ACHSPROV=$P(ACHSDOCR,U,8) S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST S7 ; I ACHSDEST="F"!(ACHSTY'="P") G S8 I $$PARM^ACHS(2,9)'="Y" G S7A S ^ACHSTXPG(ACHSTOS,ACHSDIEN,ACHSTIEN)="" S7A ; I ACHSF638'="Y" G S8 S:'$P(ACHSDOCR,U,3) ^ACHSTXPG(ACHSTOS,ACHSDIEN,ACHSTIEN)="" G S5 S8 ; G S5:ACHSTY="P" I ACHSF638="Y",$$PARM^ACHS(2,9)="Y" G S5 S ^ACHSTXOB(ACHSDIEN,ACHSTIEN)="" ; I +$P(ACHSDOCR,U,22),+$P(ACHSDOCR,U,20),+$P(ACHSDOCR,U,21) S ^ACHSTXPT(+$P(ACHSDOCR,U,22),+$P(ACHSDOCR,U,20),+$P(ACHSDOCR,U,21))=ACHSDEST ; S (ACHSX,X1)=$P(ACHSDOCR,U,14) D FYCVT^ACHSFU S ACHSXLOC=ACHSFC S:ACHSY<1987 ACHSXLOC="0"_$E(ACHSFC,2,3) S ACHSEFDT=$E(DT,4,5)_$E(DT,6,7)_$E(DT,2,3),ACHSCDE=$S(ACHSCTY="I":"05013",ACHSCTY="F":"05024",ACHSCTY="P":"05025",ACHSTY="S":"05015",1:"") S ACHSDOCN=0_X1_ACHSXLOC_$P(ACHSDOCR,U) S:'$D(^ACHSTXVN(ACHSPROV)) ^ACHSTXVN(ACHSPROV)=ACHSDEST ; G ERROR^ACHSTX:ACHSCDE="" D CANOBJ^ACHSTX8 S ACHSFED=$S($P(^AUTTVNDR(ACHSPROV,11),U,10)=2:2,1:1) S ACHSRCT=ACHSRCT+1,ACHSRTYP(2)=ACHSRTYP(2)+1 ;S ^ACHSDATA(ACHSRCT)="2"_ACHSEFDT_ACHSCDE_$S(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_ACHSDOCN_$J("",13)_"1"_X1_ACHSCAN_ACHSSCC_ACHSIPA_ACHSFED_$J("",16) ;ACHS*3*3 S ^ACHSDATA(ACHSRCT)="2"_ACHSEFDT_ACHSCDE_$S(ACHSTOS=1:323,ACHSTOS=2:324,ACHSTOS=3:325,1:"")_ACHSDOCN_$J("",13)_"1"_X1_ACHSCAN_ACHSOBJC_ACHSIPA_ACHSFED_$J("",16) ;ACHS*3*3 I $L(^ACHSDATA(ACHSRCT))'=80 W !!,*7,*7,"A DHR RECORD WAS PRODUCED THAT WAS NOT 80 CHARACTERS IN LENGTH:",!!,^(ACHSRCT),!,*7,*7 G ERROR^ACHSTX I ACHSRCT=1 S ACHSFDT=ACHSBDT W !!,"NUMBER OF RECORDS PROCESSED = ",!! W $J(ACHSRCT,8) D BC^ACHSTX2 G S5 ; ERR ; W !!,*7,*7,"DCR REGISTER ERROR YOU MUST CLOSE YOUR REGISTERS FIRST" D ^%ZISC,KILL^ACHSTX8 Q ; AFACERR ; W !!,*7,*7,"AUTHORIZING FACILITY CODE ERROR - JOB CANCELLED" D ^%ZISC,KILL^ACHSTX8 Q ; CVTEND1 ; S ACHSROUT=ACHSRCT S:ACHSRCT>2 ACHSROUT=ACHSRCT KILL ACHSDEST,ACHSDCR,ACHSF638,ACHSIPA,ACHSCAN,ACHSCDE,ACHSCTY,ACHSDOCN,ACHSDOCR,ACHSEFDT,ACHSPROV,ACHSFED,ACHSSCC,ACHSTRNR,ACHSTY,X1,ACHSXLOC G ^ACHSTX3 ; ACHSZZ03 ACHSZZ03 ;DJM;FIX DB CHR<-->RCIS [ 03/19/98 3:21 PM ] ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**2**; ;;ACHS*3*2 FIX CHS/RCIS POINTER PROBLEM K ^ACHSZZ03 S U="^" S RIEN=0,ECNT=0 F S RIEN=$O(^BMCREF(RIEN)) Q:RIEN'=+RIEN D . ;GET THE RCIS PATIENT DEMOGRAPHICS . S BMCR=$P(^BMCREF(RIEN,0),U,1) ;.01 . S BMCRNUM=$P(^BMCREF(RIEN,0),U,2) ;.02 . S BMCRPAT=$P(^BMCREF(RIEN,0),U,3) ;.03 . S RCIEN=0,EFLG=0 . F S RCIEN=$O(^BMCREF(RIEN,41,RCIEN)) Q:RCIEN'=+RCIEN D . . ;DO WE HAVE A CHS ENTRY? . . I '$D(^ACHSF(DUZ(2),"D",RCIEN)) D Q ;NO FURTHUR CHECKS ALLOWED . . . S EFLG=1,^ACHSZZ03("MISSING.PO",RCIEN,RIEN)="" . . . S ^ACHSZZ03("DELETE",RCIEN,RIEN)="" . . . S ^ACHSZZ03("PO",RCIEN,RIEN)="" . . ;GET THE CHS PATIENT IEN . . S ACHSPAT=$P(^ACHSF(DUZ(2),"D",RCIEN,0),U,22) . . ;DO WE HAVA A CHS LINK VALUE (IEN OF REFERRAL) . . I '$D(^ACHSF(DUZ(2),"D",RCIEN,2)) D Q ;NO FURTHUR CHECKS ALLOWED . . . S EFLG=1,^ACHSZZ03("MISSING.LINK",RCIEN,RIEN)="" . . . S ^ACHSZZ03("DELETE",RCIEN,RIEN)="" . . . S ^ACHSZZ03("PO",RCIEN,RIEN)="" . . ;GET THE CHS LINK TO RCIS . . S ACHSRIEN=$P(^ACHSF(DUZ(2),"D",RCIEN,2),U,7) . . I ACHSRIEN="" D ; NO BACK POINTER FROM CHS TO REFERRAL . . . S EFLG=1,^ACHSZZ03("DELETE",RCIEN,RIEN)="" . . ;DOES CHS POINT TO THE CORRECT REFERRAL? . . I ACHSPAT=BMCRPAT D . . . I $D(^ACHSZZ03("DUP",RCIEN)) D Q . . . . S ^ACHSZZ03("DUP",RCIEN,RIEN)="" . . . I $D(^ACHSZZ03("OK",RCIEN)) D Q . . . . S ^ACHSZZ03("DUP",RCIEN,RIEN)="" . . . . M ^ACHSZZ03("DUP",RCIEN)=^ACHSZZ03("OK",RCIEN) . . . . K ^ACHSZZ03("OK",RCIEN) . . . S ^ACHSZZ03("OK",RCIEN,RIEN)="" . . I RIEN'=ACHSRIEN D . . . S EFLG=1 . . . S ^ACHSZZ03("PO",RCIEN,RIEN)="" . . . S:ACHSRIEN]"" ^ACHSZZ03("PO",RCIEN,ACHSRIEN)="" . . . S ^ACHSZZ03("R",RIEN,RCIEN)="" . . . S:ACHSRIEN]"" ^ACHSZZ03("R",ACHSRIEN,RCIEN)="" . I EFLG S ECNT=ECNT+1 S ^ACHSZZ03("ECNT")=ECNT W !,"ERRORS FOUND: ",ECNT QUIT FIX ;FIX THE ^ACHSF AND ^BMCREF,^BMCDX,^BMCPX DATABASES ; ; OK -- HERE IS THE PLAN: ; ; 1) DELETE ALL BAD PO'S FROM THE REFERRALS ; 2) REPOINT RCIS DX&PX TO THE CORRECT REFERRAL ; 3) FIX THE CHS PO REFERRAL POINTER ; 4) USE AUTH^ACHSBMC TO UPDATE REFERRALS W/ CORRECT DOLLARS ; 5) DELETE STRAY POINTERS FROM RCIS TO CHS PO'S ; S U="^" R !,"START WITH PO#: ",CIEN S CIEN=$O(^ACHSZZ03("PO",CIEN),-1) F S CIEN=$O(^ACHSZZ03("PO",CIEN)) Q:CIEN="" D . I $D(^ACHSZZ03("FIXED",CIEN)) Q ; ALREADY FIXED . I $$ASK("DO FIXES FOR "_CIEN)="Y" D ; YES FIX THIS ONE . . D RDELPO(CIEN) ; STEP 1 . . D TSTDXPX(CIEN) ; STEP 2 . . D FIXRIEN(CIEN) ; STEP 3 . . D FIXAUTH(CIEN) ; STEP 4 . . D DELETE(CIEN) ; STEP 5 . . S ^ACHSZZ03("FIXED",CIEN)="" QUIT RDELPO(CIEN) ;PHASE 1 CLEAN UP, REMOVE ALL MISS LINKED PO'S ; FROM THE RCIS DATABASE ; ; CIEN = CHS PO IEN S RIEN="" F S RIEN=$O(^ACHSZZ03("PO",CIEN,RIEN)) Q:RIEN="" D . D AUTH^BMCCHS(RIEN,CIEN,"D") QUIT TSTDXPX(CIEN) ;PHASE 2 CORRECT THE DX & PX ITEMS ; TEST THE DX AND PX ENTRIES FOR CORRECTNESS ; ; CIEN = CHS PO IEN ; S ACHSPAT=$P(^ACHSF(DUZ(2),"D",CIEN,0),U,22) S BMCRIEN=$O(^ACHSZZ03("OK",CIEN,"")) ; CORRECT REFERRAL I BMCRIEN="" D Q ; PANIC, THERE IS NO CORRECT REFERRAL LOGGED . S ^ACHSZZ03("PANIC",CIEN)="" . W !,"***** PANIC: ",CIEN," DOES NOT HAVE A CORRECT REFERRAL" S WRIEN="" F S WRIEN=$O(^ACHSZZ03("PO",CIEN,WRIEN)) Q:WRIEN="" D . I $D(^ACHSZZ03("OK",CIEN,WRIEN)) Q ; DOES NOT NEED FIXING . I $D(^ACHSZZ03("FIXED.DX",CIEN,WRIEN)) Q ; FIXED . I $D(^ACHSZZ03("FIXED.PX",CIEN,WRIEN)) Q ; FIXED . D FIXDXPX(CIEN,WRIEN,BMCRIEN,ACHSPAT) QUIT FIXDXPX(CIEN,WRIEN,RIEN,CPAT) ; ; OK ... THIS IS THE PLAN FOR THE DX'S AND PX'S ; JUST RESET THE ^BMCDX(DXIEN,0) POINTER AND THE ^BMCPX(PXIEN,0) ; POINTER. ; ; CIEN = CHS PO IEN ; WRIEN = WRONG REFERRAL IEN ; RIEN = CORRECT REFERRAL IEN ; CPAT = CHS PATIENT IEN ; ; FIX THE ^BMCDX GLOBAL (PATIENT DIAGNOSIS'S) S DXIEN="" F S DXIEN=$O(^BMCDX("AD",WRIEN,DXIEN)) Q:DXIEN="" D . S DXPAT=$P(^BMCDX(DXIEN,0),U,2) Q:CPAT'=DXPAT . S ^ACHSZZ03("FIXED.DX",CIEN,DXIEN)=WRIEN_U_RIEN . S ^BMCDX("AD",RIEN,DXIEN)="" ; CORRECT THE XREF . K ^BMCDX("AD",WRIEN,DXIEN) ; REMOVE THE WRONG XREF . S $P(^BMCDX(DXIEN,0),U,3)=RIEN ; CORRECT THE REFERRAL LINK ; ; FIX THE ^BMCPX GLOBAL (PATIENT PROCEDURES'S) S PXIEN="" F S PXIEN=$O(^BMCPX("AD",WRIEN,PXIEN)) Q:PXIEN="" D . S PXPAT=$P(^BMCPX(PXIEN,0),U,2) Q:CPAT'=PXPAT . S ^ACHSZZ03("FIXED.PX",CIEN,PXIEN)=WRIEN_U_RIEN . S ^BMCPX("AD",RIEN,PXIEN)="" ; CORRECT THE XREF . K ^BMCPX("AD",WRIEN,PXIEN) ; REMOVE THE WRONG XREF . S $P(^BMCPX(PXIEN,0),U,3)=RIEN ; CORRECT THE REFERRAL LINK QUIT FIXRIEN(CIEN) ;PHASE 3 FIX THE CHS TO RCIS LINK S RIEN=$O(^ACHSZZ03("OK",CIEN,"")) I RIEN="" D Q ; PANIC, NO CORRECT REFERRAL LOGGED . S ^ACHSZZ03("PANIC",CIEN)="" . W !,"***** PANIC: ",CIEN," DOES NOT HAVE A CORRECT REFERRAL" S $P(^ACHSF(DUZ(2),"D",CIEN,2),U,7)=RIEN S ^ACHSZZ03("FIXED",CIEN)="" QUIT FIXAUTH(CIEN) ;PHASE 4 FIX THE AUTHORIZATION DOLLARS S ACHSREF=$O(^ACHSZZ03("OK",CIEN,"")) S ACHSDIEN=CIEN D AUTH^ACHSBMC QUIT DELETE(CIEN) ;PHASE 5 DELETE STRAY RCIS PO POINTERS I '$D(^ACHSZZ03("DELETE",CIEN)) Q ; NOT A STRAY POINTER S RIEN="" F S RIEN=$O(^ACHSZZ03("DELETE",CIEN,RIEN)) Q:RIEN="" D . D AUTH^BMCCHS(RIEN,CIEN,"D") QUIT ASK(MSG) ;YES/NO PROMPTING I $G(ANS)="ALL" Q "Y" ; DO THEM ALL F W !,MSG R ": ",ANS Q:ANS?1(1"Y",1"N",1"ALL") I ANS="ALL" Q "Y" Q ANS