PSGSICH ;BIR/JCH-PROVIDER & PHARMACY OVERRIDE UTILITIES ; 08/19/11 1:02pm
;;5.0;INPATIENT MEDICATIONS;**254,304**;16 DEC 97;Build 22
;
; Reference to ^APSPQA(32.4 is supported by DBIA #2179
;
NAME(TMPDUZ,NAME,INIT) ;
;TMPDUZ = IEN or Name in VA(200
;NAME = Return IEN in VA(200
;INIT = Return the initial
NEW IEN,DIC,Y,X S X=TMPDUZ
S DIC="^VA(200,",DIC(0)="NZ" D ^DIC
S IEN=+Y,NAME=$G(Y(0,0)),INIT=$P($G(Y(0)),U,2)
Q
;
HLD ; Prompt user to continue or exit
K DIR
S DIR(0)="E",DIR("A")="Press RETURN to Continue or '^' to Exit "
D ^DIR K DIR I 'Y S PSJQUITD=1
W @IOF
Q
;
ORDEXIST(PSGP,PSGORD) ; Has order been filed?
Q:'$G(PSGP) 0
I $G(PSGORD)["P",$D(^PS(53.1,+PSGORD,0)) Q 1
I $G(PSGORD)["U",$D(^PS(55,PSGP,5,+PSGORD,0)) Q 1
I $G(PSGORD)["V",$D(^PS(55,PSGP,"IV",+PSGORD,0)) Q 1
Q 0
;
OROICHK(DFN,ORDER,PSJOVRAR) ; Find the CPRS order number associated with the last Orderable Item edit
N OCI,TMPOI,CURROI,TMPORDER,PSJOCDT K CURRCPRS
I '$G(DFN)!'$G(ORDER) Q 0
S CURROI=$S(ORDER["P":+$G(^PS(53.1,+ORDER,.2)),ORDER["U":+$G(^PS(55,DFN,5,+ORDER,.2)),ORDER["V":+$G(^PS(55,DFN,"IV",+ORDER,.2)),1:"")
Q:'CURROI 0
S PSJOCDT="" F S PSJOCDT=$O(PSJOVRAR(DFN,ORDER,PSJOCDT),-1) Q:PSJOCDT=""!$G(CURRCPRS) S OCI="" F S OCI=$O(PSJOVRAR(DFN,ORDER,PSJOCDT,OCI)) Q:'OCI!$G(CURRCPRS) S TMPORDER=$G(PSJOVRAR(DFN,ORDER,PSJOCDT,OCI)) I TMPORDER D
.S TMPOI=$S(TMPORDER["P":+$G(^PS(53.1,+TMPORDER,.2)),TMPORDER["U":+$G(^PS(55,DFN,5,+TMPORDER,.2)),ORDER["V":+$G(^PS(55,DFN,"IV",+TMPORDER,.2)),1:"")
.Q:'TMPOI I TMPOI'=CURROI S CURRCPRS=$S(TMPORDER["P":$P($G(^PS(53.1,+TMPORDER,0)),"^",21),TMPORDER["U":$P($G(^PS(55,DFN,5,+TMPORDER,0)),"^",21),TMPORDER["V":$P($G(^PS(55,DFN,"IV",+TMPORDER,0)),"^",21),1:"")
Q +$G(CURRCPRS)
;
ONEINTER(INTER,PSJORDER,PSJIDTM,OUTARRAY) ; Accept one intervention IEN and return OUTARRAY with formatted intervention information
; INPUT: INTER = Intervention IEN from ^APSPQA(32.4
; PSJORDER = Inpatient Order
; PSJIDTM = Order Date/Time
; OUTARRAY = Array containing CPRS overrides and pharmacy interventions
Q:'$G(INTER) Q:'$D(^APSPQA(32.4,+INTER))
D INTRDICO^PSGSICH2(+INTER)
S INT=0 F S INT=$O(^UTILITY("DIQ1",$J,9009032.4,INT)) Q:'INT D INTROUT^PSGSICH2(INT,PSJIDTM,$S($G(PSJORDER):PSJORDER,1:0),.OUTARRAY)
K ^UTILITY("DIQ1",$J)
Q
;
CHKADD(PSJINTER,PSGP,PSJIVORN) ; Check for existence of Intervention Orderable Item in IV Additives
N NXTADD,PSJINTOK,ADDOI,DIC,DR,DA,NXTSOL,SOLOI
Q:'$G(PSJINTER) 1
K ^UTILITY("DIQ1",$J,9009032.4) S DIC="^APSPQA(32.4,",DR=".05",DA=PSJINTER,DIQ(0)="I" D EN^DIQ1
S PSJINTOI=$G(^UTILITY("DIQ1",$J,9009032.4,PSJINTER,.05,"I")),PSJINTOI=+$G(^PSDRUG(+PSJINTOI,2)) K ^UTILITY("DIQ1",$J,9009032.4)
I 'PSJINTOI Q 1
I PSJIVORN["V" S NXTADD=0 F S NXTADD=$O(^PS(55,PSGP,"IV",+PSJIVORN,"AD",NXTADD)) Q:'NXTADD!$G(PSJINTOK) D
.N ADDIEN S ADDIEN=+$G(^PS(55,PSGP,"IV",+PSJIVORN,"AD",NXTADD,0))
.S ADDOI=$P($G(^PS(52.6,+ADDIEN,0)),"^",11) I ADDOI=PSJINTOI S PSJINTOK=1
I PSJIVORN["V",'$G(PSJINTOK) S NXTSOL=0 F S NXTSOL=$O(^PS(55,PSGP,"IV",+PSJIVORN,"SOL",NXTSOL)) Q:'NXTSOL!$G(PSJINTOK) D
.N SOLIEN S SOLIEN=+$G(^PS(55,PSGP,"IV",+PSJIVORN,"SOL",NXTSOL,0))
.S SOLOI=$P($G(^PS(52.7,+SOLIEN,0)),"^",11) I SOLOI=PSJINTOI S PSJINTOK=1
I PSJIVORN["P" S NXTADD=0 F S NXTADD=$O(^PS(53.1,+PSJIVORN,"AD",NXTADD)) Q:'NXTADD!$G(PSJINTOK) D
.N ADDIEN S ADDIEN=+$G(^PS(53.1,+PSJIVORN,"AD",NXTADD,0))
.S ADDOI=$P($G(^PS(52.6,+ADDIEN,0)),"^",11) I ADDOI=PSJINTOI S PSJINTOK=1
I PSJIVORN["P",'$G(PSJINTOK) S NXTSOL=0 F S NXTSOL=$O(^PS(53.1,+PSJIVORN,"SOL",NXTSOL)) Q:'NXTSOL!$G(PSJINTOK) D
.N SOLIEN S SOLIEN=+$G(^PS(53.1,+PSJIVORN,"SOL",NXTSOL,0))
.S SOLOI=$P($G(^PS(52.7,+SOLIEN,0)),"^",11) I SOLOI=PSJINTOI S PSJINTOK=1
Q $S($G(PSJINTOK):1,1:0)
;
SETIVIN2(PSJI1,PSJI2) ; Store Intervention pointers in the IV Intervention multiple
N PSJOLDOI,PSJNEWOI,DINUM,PSJICNT,PSJINTDT
Q:'$G(DFN)
I $D(^TMP("PSJINTER",$J)) D STOREINT^PSGSICH1 K ^TMP("PSJINTER",$J) Q
I ($G(PSJI1)["P"),$G(PSJI2)["V" I $O(^PS(53.1,+$G(PSJI1),11,0)) D Q
.S PSJNEWOI=+$G(^PS(55,DFN,"IV",+PSJI2,.2)),PSJOLDOI=+$G(^PS(53.1,+PSJI1,.2)) Q:'PSJNEWOI Q:(PSJNEWOI'=PSJOLDOI)
.N PSJINCNT,PSJNXTI,PSJINTER,DO K DA,DIC S PSJINCNT=+$P($G(^PS(55,DFN,"IV",+PSJI2,8,0)),"^",3)
.S PSJNXTI="B" F S PSJNXTI=$O(^PS(53.1,+$G(PSJI1),11,PSJNXTI),-1) Q:'PSJNXTI D
..S PSJINTER=$G(^PS(53.1,+$G(PSJI1),11,PSJNXTI,0)) Q:'PSJINTER Q:$D(^PS(55,DFN,"IV",+$G(PSJI2),8,"B",+PSJINTER))
..S PSJICNT=$G(PSJICNT)+1 I PSJICNT=1 S PSJINTDT=$P(PSJINTER,"^",2)
..I $G(PSJINTDT) Q:(PSJINTDT'=$P(PSJINTER,"^",2))
..Q:'$$CHKADD(+PSJINTER,DFN,PSJI2)
..S PSJINCNT=$G(PSJINCNT)+1
..S DIC="^PS(55,"_+DFN_",""IV"","_+PSJI2_",8,",DIC(0)="L",DIC("P")="55.1153PA",DA(1)=+PSJI2,DA(2)=DFN,(DINUM,X)=+PSJINCNT
..S DIC("DR")=".01////"_+PSJINTER_";1////"_$P(PSJINTER,"^",2)_";" D FILE^DICN
.K DIC,DA
I ($G(PSJI1)["V"),($G(PSJI2)["P") I $O(^PS(55,DFN,"IV",+PSJI1,8,0)) D Q
.S PSJOLDOI=+$G(^PS(55,DFN,"IV",+PSJI1,.2)),PSJNEWOI=+$G(^PS(53.1,+PSJI2,.2)) I $G(PSJNEWOI) Q:(PSJNEWOI'=PSJOLDOI)
.N PSJINCNT,PSJNXTI,PSJINTER K DA,DIC S PSJINCNT=+$P($G(^PS(53.1,+PSJI2,11,0)),"^",3)
.S PSJNXTI="B" F S PSJNXTI=$O(^PS(55,DFN,"IV",+$G(PSJI1),8,PSJNXTI),-1) Q:'PSJNXTI D
..S PSJINTER=$G(^PS(55,DFN,"IV",+$G(PSJI1),8,PSJNXTI,0)) Q:'PSJINTER Q:$D(^PS(53.1,+PSJI2,11,"B",+PSJINTER))
..S PSJICNT=$G(PSJICNT)+1 I PSJICNT=1 S PSJINTDT=$P(PSJINTER,"^",2)
..I $G(PSJINTDT) Q:(PSJINTDT'=$P(PSJINTER,"^",2))
..I $D(^PS(53.1,+PSJI2,"AD")) Q:'$$CHKADD(+PSJINTER,DFN,PSJI2)
..N IC,IG S (IG,IC)=0 F Q:$G(IG) S IC=$O(^PS(53.1,+PSJI2,11,IC)) Q:'IC!$G(IG) S:(+$G(^PS(53.1,+PSJI2,11,IC,0))=+PSJINTER) IG=1
..Q:$G(IG) S PSJINCNT=$G(PSJINCNT)+1 S DIC="^PS(53.1,"_+PSJI2_",11,",DIC(0)="L",DIC("P")="53.13PA",DA(2)=+PSJI2,X=+PSJINTER,(DINUM,DA(1))=+PSJINCNT
..S DIC("DR")=".01////"_+PSJINTER_";1////"_$P(PSJINTER,"^",2)_";" D FILE^DICN
I ($G(PSJI1)["P"),($G(PSJI2)["P") I $O(^PS(53.1,+PSJI1,11,0)) D Q
.S PSJOLDOI=+$G(^PS(53.1,+PSJI1,.2)),PSJNEWOI=+$G(^PS(53.1,+PSJI2,.2)) I $G(PSJNEWOI) Q:(PSJNEWOI'=PSJOLDOI)
.I PSJI1=PSJI2 Q:$G(ON)'["P" Q:'$D(^PS(53.1,+ON,0)) S PSJI2=ON
.N PSJINCNT,PSJNXTI,PSJINTER K DA,DIC S PSJINCNT=+$P($G(^PS(53.1,+PSJI2,11,0)),"^",3)
.S PSJNXTI="B" F S PSJNXTI=$O(^PS(53.1,+PSJI1,11,PSJNXTI),-1) Q:'PSJNXTI D
..S PSJINTER=$G(^PS(53.1,+PSJI1,11,PSJNXTI,0)) Q:'PSJINTER Q:$D(^PS(53.1,+PSJI2,"B",+PSJINTER))
..S PSJICNT=$G(PSJICNT)+1 I PSJICNT=1 S PSJINTDT=$P(PSJINTER,"^",2)
..I $G(PSJINTDT) Q:(PSJINTDT'=$P(PSJINTER,"^",2))
..I $D(^PS(53.1,+PSJI2,"AD")) Q:'$$CHKADD(PSJINTER,DFN,PSJI2)
..N IC,IG S (IG,IC)=0 F Q:$G(IG) S IC=$O(^PS(53.1,+PSJI2,11,IC)) Q:'IC!$G(IG) S:(+$G(^PS(53.1,+PSJI2,11,IC,0))=+PSJINTER) IG=1
..Q:$G(IG) Q:$D(^PS(53.1,+PSJI2,11,"B",+PSJINTER)) S PSJINCNT=$G(PSJINCNT)+1
..S DIC="^PS(53.1,"_+PSJI2_",11,",DIC(0)="L",DIC("P")="53.13PA",DA(2)=+PSJI2,X=+PSJINTER,(DINUM,DA(1))=+PSJINCNT
..S DIC("DR")=".01////"_+PSJINTER_";1////"_$P(PSJINTER,"^",2)_";" K DO D FILE^DICN K DO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGSICH 7076 printed Dec 13, 2024@02:03:13 Page 2
PSGSICH ;BIR/JCH-PROVIDER & PHARMACY OVERRIDE UTILITIES ; 08/19/11 1:02pm
+1 ;;5.0;INPATIENT MEDICATIONS;**254,304**;16 DEC 97;Build 22
+2 ;
+3 ; Reference to ^APSPQA(32.4 is supported by DBIA #2179
+4 ;
NAME(TMPDUZ,NAME,INIT) ;
+1 ;TMPDUZ = IEN or Name in VA(200
+2 ;NAME = Return IEN in VA(200
+3 ;INIT = Return the initial
+4 NEW IEN,DIC,Y,X
SET X=TMPDUZ
+5 SET DIC="^VA(200,"
SET DIC(0)="NZ"
DO ^DIC
+6 SET IEN=+Y
SET NAME=$GET(Y(0,0))
SET INIT=$PIECE($GET(Y(0)),U,2)
+7 QUIT
+8 ;
HLD ; Prompt user to continue or exit
+1 KILL DIR
+2 SET DIR(0)="E"
SET DIR("A")="Press RETURN to Continue or '^' to Exit "
+3 DO ^DIR
KILL DIR
IF 'Y
SET PSJQUITD=1
+4 WRITE @IOF
+5 QUIT
+6 ;
ORDEXIST(PSGP,PSGORD) ; Has order been filed?
+1 if '$GET(PSGP)
QUIT 0
+2 IF $GET(PSGORD)["P"
IF $DATA(^PS(53.1,+PSGORD,0))
QUIT 1
+3 IF $GET(PSGORD)["U"
IF $DATA(^PS(55,PSGP,5,+PSGORD,0))
QUIT 1
+4 IF $GET(PSGORD)["V"
IF $DATA(^PS(55,PSGP,"IV",+PSGORD,0))
QUIT 1
+5 QUIT 0
+6 ;
OROICHK(DFN,ORDER,PSJOVRAR) ; Find the CPRS order number associated with the last Orderable Item edit
+1 NEW OCI,TMPOI,CURROI,TMPORDER,PSJOCDT
KILL CURRCPRS
+2 IF '$GET(DFN)!'$GET(ORDER)
QUIT 0
+3 SET CURROI=$SELECT(ORDER["P":+$GET(^PS(53.1,+ORDER,.2)),ORDER["U":+$GET(^PS(55,DFN,5,+ORDER,.2)),ORDER["V":+$GET(^PS(55,DFN,"IV",+ORDER,.2)),1:"")
+4 if 'CURROI
QUIT 0
+5 SET PSJOCDT=""
FOR
SET PSJOCDT=$ORDER(PSJOVRAR(DFN,ORDER,PSJOCDT),-1)
if PSJOCDT=""!$GET(CURRCPRS)
QUIT
SET OCI=""
FOR
SET OCI=$ORDER(PSJOVRAR(DFN,ORDER,PSJOCDT,OCI))
if 'OCI!$GET(CURRCPRS)
QUIT
SET TMPORDER=$GET(PSJOVRAR(DFN,ORDER,PSJOCDT,OCI))
IF TMPORDER
Begin DoDot:1
+6 SET TMPOI=$SELECT(TMPORDER["P":+$GET(^PS(53.1,+TMPORDER,.2)),TMPORDER["U":+$GET(^PS(55,DFN,5,+TMPORDER,.2)),ORDER["V":+$GET(^PS(55,DFN,"IV",+TMPORDER,.2)),1:"")
+7 if 'TMPOI
QUIT
IF TMPOI'=CURROI
SET CURRCPRS=$SELECT(TMPORDER["P":$PIECE($GET(^PS(53.1,+TMPORDER,0)),"^",21),TMPORDER["U":$PIECE($GET(^PS(55,DFN,5,+TMPORDER,0)),"^",21),TMPORDER["V":$PIECE($GET(^PS(55,DFN,"IV",+TMPORDER,0)),"^",21),1:"")
End DoDot:1
+8 QUIT +$GET(CURRCPRS)
+9 ;
ONEINTER(INTER,PSJORDER,PSJIDTM,OUTARRAY) ; Accept one intervention IEN and return OUTARRAY with formatted intervention information
+1 ; INPUT: INTER = Intervention IEN from ^APSPQA(32.4
+2 ; PSJORDER = Inpatient Order
+3 ; PSJIDTM = Order Date/Time
+4 ; OUTARRAY = Array containing CPRS overrides and pharmacy interventions
+5 if '$GET(INTER)
QUIT
if '$DATA(^APSPQA(32.4,+INTER))
QUIT
+6 DO INTRDICO^PSGSICH2(+INTER)
+7 SET INT=0
FOR
SET INT=$ORDER(^UTILITY("DIQ1",$JOB,9009032.4,INT))
if 'INT
QUIT
DO INTROUT^PSGSICH2(INT,PSJIDTM,$SELECT($GET(PSJORDER):PSJORDER,1:0),.OUTARRAY)
+8 KILL ^UTILITY("DIQ1",$JOB)
+9 QUIT
+10 ;
CHKADD(PSJINTER,PSGP,PSJIVORN) ; Check for existence of Intervention Orderable Item in IV Additives
+1 NEW NXTADD,PSJINTOK,ADDOI,DIC,DR,DA,NXTSOL,SOLOI
+2 if '$GET(PSJINTER)
QUIT 1
+3 KILL ^UTILITY("DIQ1",$JOB,9009032.4)
SET DIC="^APSPQA(32.4,"
SET DR=".05"
SET DA=PSJINTER
SET DIQ(0)="I"
DO EN^DIQ1
+4 SET PSJINTOI=$GET(^UTILITY("DIQ1",$JOB,9009032.4,PSJINTER,.05,"I"))
SET PSJINTOI=+$GET(^PSDRUG(+PSJINTOI,2))
KILL ^UTILITY("DIQ1",$JOB,9009032.4)
+5 IF 'PSJINTOI
QUIT 1
+6 IF PSJIVORN["V"
SET NXTADD=0
FOR
SET NXTADD=$ORDER(^PS(55,PSGP,"IV",+PSJIVORN,"AD",NXTADD))
if 'NXTADD!$GET(PSJINTOK)
QUIT
Begin DoDot:1
+7 NEW ADDIEN
SET ADDIEN=+$GET(^PS(55,PSGP,"IV",+PSJIVORN,"AD",NXTADD,0))
+8 SET ADDOI=$PIECE($GET(^PS(52.6,+ADDIEN,0)),"^",11)
IF ADDOI=PSJINTOI
SET PSJINTOK=1
End DoDot:1
+9 IF PSJIVORN["V"
IF '$GET(PSJINTOK)
SET NXTSOL=0
FOR
SET NXTSOL=$ORDER(^PS(55,PSGP,"IV",+PSJIVORN,"SOL",NXTSOL))
if 'NXTSOL!$GET(PSJINTOK)
QUIT
Begin DoDot:1
+10 NEW SOLIEN
SET SOLIEN=+$GET(^PS(55,PSGP,"IV",+PSJIVORN,"SOL",NXTSOL,0))
+11 SET SOLOI=$PIECE($GET(^PS(52.7,+SOLIEN,0)),"^",11)
IF SOLOI=PSJINTOI
SET PSJINTOK=1
End DoDot:1
+12 IF PSJIVORN["P"
SET NXTADD=0
FOR
SET NXTADD=$ORDER(^PS(53.1,+PSJIVORN,"AD",NXTADD))
if 'NXTADD!$GET(PSJINTOK)
QUIT
Begin DoDot:1
+13 NEW ADDIEN
SET ADDIEN=+$GET(^PS(53.1,+PSJIVORN,"AD",NXTADD,0))
+14 SET ADDOI=$PIECE($GET(^PS(52.6,+ADDIEN,0)),"^",11)
IF ADDOI=PSJINTOI
SET PSJINTOK=1
End DoDot:1
+15 IF PSJIVORN["P"
IF '$GET(PSJINTOK)
SET NXTSOL=0
FOR
SET NXTSOL=$ORDER(^PS(53.1,+PSJIVORN,"SOL",NXTSOL))
if 'NXTSOL!$GET(PSJINTOK)
QUIT
Begin DoDot:1
+16 NEW SOLIEN
SET SOLIEN=+$GET(^PS(53.1,+PSJIVORN,"SOL",NXTSOL,0))
+17 SET SOLOI=$PIECE($GET(^PS(52.7,+SOLIEN,0)),"^",11)
IF SOLOI=PSJINTOI
SET PSJINTOK=1
End DoDot:1
+18 QUIT $SELECT($GET(PSJINTOK):1,1:0)
+19 ;
SETIVIN2(PSJI1,PSJI2) ; Store Intervention pointers in the IV Intervention multiple
+1 NEW PSJOLDOI,PSJNEWOI,DINUM,PSJICNT,PSJINTDT
+2 if '$GET(DFN)
QUIT
+3 IF $DATA(^TMP("PSJINTER",$JOB))
DO STOREINT^PSGSICH1
KILL ^TMP("PSJINTER",$JOB)
QUIT
+4 IF ($GET(PSJI1)["P")
IF $GET(PSJI2)["V"
IF $ORDER(^PS(53.1,+$GET(PSJI1),11,0))
Begin DoDot:1
+5 SET PSJNEWOI=+$GET(^PS(55,DFN,"IV",+PSJI2,.2))
SET PSJOLDOI=+$GET(^PS(53.1,+PSJI1,.2))
if 'PSJNEWOI
QUIT
if (PSJNEWOI'=PSJOLDOI)
QUIT
+6 NEW PSJINCNT,PSJNXTI,PSJINTER,DO
KILL DA,DIC
SET PSJINCNT=+$PIECE($GET(^PS(55,DFN,"IV",+PSJI2,8,0)),"^",3)
+7 SET PSJNXTI="B"
FOR
SET PSJNXTI=$ORDER(^PS(53.1,+$GET(PSJI1),11,PSJNXTI),-1)
if 'PSJNXTI
QUIT
Begin DoDot:2
+8 SET PSJINTER=$GET(^PS(53.1,+$GET(PSJI1),11,PSJNXTI,0))
if 'PSJINTER
QUIT
if $DATA(^PS(55,DFN,"IV",+$GET(PSJI2),8,"B",+PSJINTER))
QUIT
+9 SET PSJICNT=$GET(PSJICNT)+1
IF PSJICNT=1
SET PSJINTDT=$PIECE(PSJINTER,"^",2)
+10 IF $GET(PSJINTDT)
if (PSJINTDT'=$PIECE(PSJINTER,"^",2))
QUIT
+11 if '$$CHKADD(+PSJINTER,DFN,PSJI2)
QUIT
+12 SET PSJINCNT=$GET(PSJINCNT)+1
+13 SET DIC="^PS(55,"_+DFN_",""IV"","_+PSJI2_",8,"
SET DIC(0)="L"
SET DIC("P")="55.1153PA"
SET DA(1)=+PSJI2
SET DA(2)=DFN
SET (DINUM,X)=+PSJINCNT
+14 SET DIC("DR")=".01////"_+PSJINTER_";1////"_$PIECE(PSJINTER,"^",2)_";"
DO FILE^DICN
End DoDot:2
+15 KILL DIC,DA
End DoDot:1
QUIT
+16 IF ($GET(PSJI1)["V")
IF ($GET(PSJI2)["P")
IF $ORDER(^PS(55,DFN,"IV",+PSJI1,8,0))
Begin DoDot:1
+17 SET PSJOLDOI=+$GET(^PS(55,DFN,"IV",+PSJI1,.2))
SET PSJNEWOI=+$GET(^PS(53.1,+PSJI2,.2))
IF $GET(PSJNEWOI)
if (PSJNEWOI'=PSJOLDOI)
QUIT
+18 NEW PSJINCNT,PSJNXTI,PSJINTER
KILL DA,DIC
SET PSJINCNT=+$PIECE($GET(^PS(53.1,+PSJI2,11,0)),"^",3)
+19 SET PSJNXTI="B"
FOR
SET PSJNXTI=$ORDER(^PS(55,DFN,"IV",+$GET(PSJI1),8,PSJNXTI),-1)
if 'PSJNXTI
QUIT
Begin DoDot:2
+20 SET PSJINTER=$GET(^PS(55,DFN,"IV",+$GET(PSJI1),8,PSJNXTI,0))
if 'PSJINTER
QUIT
if $DATA(^PS(53.1,+PSJI2,11,"B",+PSJINTER))
QUIT
+21 SET PSJICNT=$GET(PSJICNT)+1
IF PSJICNT=1
SET PSJINTDT=$PIECE(PSJINTER,"^",2)
+22 IF $GET(PSJINTDT)
if (PSJINTDT'=$PIECE(PSJINTER,"^",2))
QUIT
+23 IF $DATA(^PS(53.1,+PSJI2,"AD"))
if '$$CHKADD(+PSJINTER,DFN,PSJI2)
QUIT
+24 NEW IC,IG
SET (IG,IC)=0
FOR
if $GET(IG)
QUIT
SET IC=$ORDER(^PS(53.1,+PSJI2,11,IC))
if 'IC!$GET(IG)
QUIT
if (+$GET(^PS(53.1,+PSJI2,11,IC,0))=+PSJINTER)
SET IG=1
+25 if $GET(IG)
QUIT
SET PSJINCNT=$GET(PSJINCNT)+1
SET DIC="^PS(53.1,"_+PSJI2_",11,"
SET DIC(0)="L"
SET DIC("P")="53.13PA"
SET DA(2)=+PSJI2
SET X=+PSJINTER
SET (DINUM,DA(1))=+PSJINCNT
+26 SET DIC("DR")=".01////"_+PSJINTER_";1////"_$PIECE(PSJINTER,"^",2)_";"
DO FILE^DICN
End DoDot:2
End DoDot:1
QUIT
+27 IF ($GET(PSJI1)["P")
IF ($GET(PSJI2)["P")
IF $ORDER(^PS(53.1,+PSJI1,11,0))
Begin DoDot:1
+28 SET PSJOLDOI=+$GET(^PS(53.1,+PSJI1,.2))
SET PSJNEWOI=+$GET(^PS(53.1,+PSJI2,.2))
IF $GET(PSJNEWOI)
if (PSJNEWOI'=PSJOLDOI)
QUIT
+29 IF PSJI1=PSJI2
if $GET(ON)'["P"
QUIT
if '$DATA(^PS(53.1,+ON,0))
QUIT
SET PSJI2=ON
+30 NEW PSJINCNT,PSJNXTI,PSJINTER
KILL DA,DIC
SET PSJINCNT=+$PIECE($GET(^PS(53.1,+PSJI2,11,0)),"^",3)
+31 SET PSJNXTI="B"
FOR
SET PSJNXTI=$ORDER(^PS(53.1,+PSJI1,11,PSJNXTI),-1)
if 'PSJNXTI
QUIT
Begin DoDot:2
+32 SET PSJINTER=$GET(^PS(53.1,+PSJI1,11,PSJNXTI,0))
if 'PSJINTER
QUIT
if $DATA(^PS(53.1,+PSJI2,"B",+PSJINTER))
QUIT
+33 SET PSJICNT=$GET(PSJICNT)+1
IF PSJICNT=1
SET PSJINTDT=$PIECE(PSJINTER,"^",2)
+34 IF $GET(PSJINTDT)
if (PSJINTDT'=$PIECE(PSJINTER,"^",2))
QUIT
+35 IF $DATA(^PS(53.1,+PSJI2,"AD"))
if '$$CHKADD(PSJINTER,DFN,PSJI2)
QUIT
+36 NEW IC,IG
SET (IG,IC)=0
FOR
if $GET(IG)
QUIT
SET IC=$ORDER(^PS(53.1,+PSJI2,11,IC))
if 'IC!$GET(IG)
QUIT
if (+$GET(^PS(53.1,+PSJI2,11,IC,0))=+PSJINTER)
SET IG=1
+37 if $GET(IG)
QUIT
if $DATA(^PS(53.1,+PSJI2,11,"B",+PSJINTER))
QUIT
SET PSJINCNT=$GET(PSJINCNT)+1
+38 SET DIC="^PS(53.1,"_+PSJI2_",11,"
SET DIC(0)="L"
SET DIC("P")="53.13PA"
SET DA(2)=+PSJI2
SET X=+PSJINTER
SET (DINUM,DA(1))=+PSJINCNT
+39 SET DIC("DR")=".01////"_+PSJINTER_";1////"_$PIECE(PSJINTER,"^",2)_";"
KILL DO
DO FILE^DICN
KILL DO
End DoDot:2
End DoDot:1
QUIT
+40 QUIT
