11:24 AM  28-Apr-98
ACHS*3*2 FIX CHS/RCIS POINTER PROBLEM & CAPTION PRINT ERROR
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
 ;

ACHSBMC
ACHSBMC ; IHS/ADC/GTH - RCIS INTERFACE SUBROUTINES ; [ 09/17/97   9:12 AM ]
 ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**2**;SEP 17, 1997
 ;;ACHS*3*2 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:"<missing>"),"'."
 .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(.06) S ACHS(.06)=$P(^(0),U,2)
 . I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,3)>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)
 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
 ;
 ; -----------------------------------------------------------
 ;

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)'<ACHSFDT)!(I(N,8)="")) 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(N,2),1,(38-$L(I(N,5))))_" "_I(N,5)_"^EFF:"_I(N,7)_" "_I(N,8)
 . K I(N)
 .Q
MCR ;
 S N=N+1
 G MCD:'$D(^AUPNMCR("B",DFN))
 S ACHSMR=N,ACHSMDFN=0,ACHSMDFN=$O(^AUPNMCR("B",DFN,ACHSMDFN)),ACHSINS=^AUPNMCR(ACHSMDFN,0)
 G:$P(ACHSINS,U,3)="" MCD
 D DINACK("^AUPNMCR")
 G MCD:ACHSBZD("OK")="N"
 ;
 S I(N,5)=$P(ACHSINS,U,3)
 S:$P(ACHSINS,U,4)'="" I(N,5)=I(N,5)_$P(^AUTTMCS($P(ACHSINS,U,4),0),U)
 S I(N,1)=$S($D(^AUPNMCR(ACHSMDFN,21)):$P(^(21),U),'$D(^(21)):$P(^DPT(DFN,0),U))
 D SET("^AUPNMCR")
MCD ;
 G RRE:'$D(^AUPNMCD("B",DFN))
 S ACHSMDFN=0,ACHSMR=N,ACHSMDFN=$O(^AUPNMCD("B",DFN,ACHSMDFN))
 G:ACHSMDFN="" RRE
 D DINACK("^AUPNMCD")
 G RRE:ACHSBZD("OK")="N"
 ;
 S ACHSINS=^AUPNMCD(ACHSMDFN,0),I(N,5)=$P(ACHSINS,U,3),I(N,1)=$P(ACHSINS,U,5)
 D SET("^AUPNMCD")
RRE ;
 G END:'$D(^AUPNRRE("B",DFN))
 S ACHSMDFN=0,ACHSMR=N,ACHSMDFN=$O(^AUPNRRE("B",DFN,ACHSMDFN))
 G:ACHSMDFN="" END
 D DINACK("^AUPNMRRE")
 G END:ACHSBZD("OK")="N"
 ;
 S ACHSINS=^AUPNRRE(ACHSMDFN,0),I(N,5)=$P(ACHSINS,U,3),I(N,1)=$P(ACHSINS,U,5)
 D SET("^AUPNRRE")
END ;
 KILL ACHSMDFN,DA,ACHSGL,ACHSINS,ACHSINS1,ACHSMR,ACHSBZD
 Q
 ;
SET(ACHSGL) ;
 S I(N,2)=$P(^AUTNINS($P(ACHSINS,U,2),0),U)
 S DA=0
 F  S DA=$O(@ACHSGL@(ACHSMDFN,11,DA)) Q:'DA  D  ;S N=N+1  dmh commented
 . S I(N,6)=$P(@ACHSGL@(ACHSMDFN,11,DA,0),U,3),I(N,7)=$P(^(0),U),I(N,8)=$P(^(0),U,2)
 . Q:(ACHSBZD("DT")<I(N,7))  ; -- ACHSBZD("DT") gets set from DINACK
 . Q:(I(N,8)'="")&(ACHSBZD("DT")>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("B"))&(ACHSBZD("DT")'>ACHSBZD("E")) S ACHSBZD("OK")="Y" Q
 . I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="") S ACHSBZD("OK")="Y" Q
 Q
 ;
DINAPI ;-- Check for PI eligibility at Date Of Service.  Else, no print.
 S ACHSBZD("OK")="N"
 Q:'$D(C(5))
 S X=C(5),%DT=""
 D ^%DT
 S ACHSBZD("DT")=Y
 S ACHSBZD("B")=$P(ACHSINS,U,6),ACHSBZD("E")=$P(ACHSINS,U,7)
 I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("DT")'>ACHSBZD("E")) S ACHSBZD("OK")="Y" Q
 I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="") S ACHSBZD("OK")="Y" Q
 Q
 ;

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