- 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 Feb 18, 2025@23:29:37 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