- PSJNEWOA ;BIR/SAB - STORES BACKDOOR ORDER CHECKS IN FILE #100.05 ;11/08/2012
- ;;5.0;INPATIENT MEDICATIONS;**281**;16 DEC 97;Build 113
- ;External reference to ^TMP("PSODAOC",$J is supported by DBIA# 6071
- ;External reference to GETOC4^OROCAPI1 supported by DBIA 5729
- ;External reference to ^ORD(100.05 supported by DBIA 5731
- ;External reference to ^PS(55 supported by DBIA 2191
- ;
- ;Inpatient: When verifying order within the same session, pull allergies from non-verified order to verified order
- ;called from VF1^PSJLIACT and PSJHL3
- VF ;unit dose or pending
- Q:'$G(^TMP("PSODAOC",$J,"IP IEN"))
- N PSJORET,PSJZORN,RXORDER,PSJDGVER,PSJOORD,ON55
- S (PSJZORN,PSJORET,PSJOORD,PSJORET)="",PSJDGVER=1,PSJOORD=$G(^TMP("PSODAOC",$J,"IP IEN"))
- I $G(PSJSPEED) S PSJOORD=$G(ON55)
- S (ON55,RXORDER)=$G(^TMP("PSODAOC",$J,"IP NEW IEN"))
- D VF2
- Q
- VF1 ;IV or edit
- N PSJDGORD,PSJORET,PSJZORN,RXORDER,ON55
- I $G(PSIVCOPY),($G(ON55)["V") K ^TMP("PSODAOC",$J,"ALLERGY")
- S (PSJZORN,PSJORET)="",(ON55,RXORDER)=$G(^TMP("PSODAOC",$J,"IP NEW IEN"))
- S PSJDGORD=$G(^TMP("PSODAOC",$J,"IP IEN"))
- VF2 ;
- I $G(PSJDGVER)&($G(PSJOORD)) D
- .I PSJOORD["P"!(PSJOORD["N") S PSJZORN=+$P(^PS(53.1,+PSJOORD,0),U,21) Q
- ;
- I '$G(PSJREN)&('$G(PSJDGVER))&($G(PSJDGORD)) D
- .I PSJDGORD["P"!(PSJDGORD["N") S PSJZORN=+$P($G(^PS(53.1,+PSJDGORD,0)),U,21) Q
- .S PSJZORN=$S(PSJDGORD["V":$P($G(^PS(55,DFN,"IV",+PSJDGORD,0)),"^",21),PSJDGORD["U":$P($G(^PS(55,DFN,5,+PSJDGORD,0)),"^",21),1:"")
- I $G(PSJREN)&('$G(PSJDGVER))&($G(PSJDGORD)) S PSJZORN=$S(PSJDGORD["V":$P($G(^PS(55,DFN,"IV",+PSJDGORD,0)),"^",21),PSJDGORD["U":$P($G(^PS(55,DFN,5,+PSJDGORD,0)),"^",21),1:"")
- Q:'PSJZORN
- D GETOC4^OROCAPI1(PSJZORN,.PSJORET)
- I $O(PSJORET(PSJZORN,"DATA",""))="" K ^TMP("PSODAOC",$J) Q
- ;
- VF3 ;
- N PSJZI,PSJZIIEN,PSJNRET,PSJACNT,PSJACNT1,PSJACNT2,PSJIEN60,PSJIEN70,PSJRETI,PSJDFLAG,PSJZERO,PSOZH,PSJOZI
- S (PSJACNT,PSJACNT1)=0
- F PSJZI=0:0 S PSJZI=$O(PSJORET(PSJZORN,"DATA",PSJZI)) Q:'PSJZI I $D(PSJORET(PSJZORN,"DATA",PSJZI,1)) D
- .Q:+$P(PSJORET(PSJZORN,"DATA",PSJZI,1),";",2)'=3
- .K PSJAIENS
- .I $G(PSJOZI)'=PSJZI S PSJZIIEN=0
- .S PSJOZI=PSJZI,PSJACNT=PSJACNT+1
- .F S PSJZIIEN=$O(^ORD(100.05,PSJZI,4,PSJZIIEN)) Q:PSJZIIEN="" I $D(^ORD(100.05,PSJZI,4,PSJZIIEN,0)) D
- ..Q:$P(^ORD(100.05,PSJZI,0),"^",3)["CPRS"
- ..D GETS^DIQ(100.05,PSJZI,"60*","I","PSJIEN60"),GETS^DIQ(100.05,PSJZI,"70*","I","PSJIEN70")
- ..S PSJDFLAG="",PSJDFLAG=$$GETORD(PSJZI,$S($G(PSJDGVER):$G(PSJOORD),1:PSJDGORD),PSJDFLAG)
- ..Q:'$G(PSJDFLAG)
- ..;
- ..S PSJACNT1=PSJACNT1+1
- ..S ^TMP("PSODAOC",$J,"ALLERGY",PSJACNT,"ALLERGY PKG")="IP^"_$S($G(PSJOCFG)]"":$P(PSJOCFG," ")_" ",1:"")_"^"_ON55_"^"_PSJZORN
- ..;S:$D(^ORD(100.05,PSJZI,8)) ^TMP("PSODAOC",$J,"ALLERGY",PSJACNT,"INTERVENTION")=^ORD(100.05,PSJZI,8)
- ..S ^TMP("PSODAOC",$J,"ALLERGY","PROVR")=$G(PSJORET(PSJZI,"DATA",PSJZIIEN,"OR",1,0))
- ..;
- ..D SETTMP
- ;
- VF4 ;
- S PSOZH="Allergy",RXORDER=ON55,PSJAOC1=1
- S (ON55,RXORDER)=$G(^TMP("PSODAOC",$J,"IP NEW IEN"))
- I $D(^TMP("PSODAOC",$J,"ALLERGY")) D VF2^PSJNEWOC
- K ^TMP("PSODAOC",$J,"ALLERGY")
- Q
- ;
- SETTMP ;
- N PSJSUBS,PSJACNT2
- S ^TMP("PSODAOC",$J,"ALLERGY",PSJACNT,4,PSJZIIEN,0)=$G(^ORD(100.05,PSJZI,4,PSJZIIEN,0))
- ;
- I $D(^ORD(100.05,PSJZI,4,PSJZIIEN,1,0)) S PSJSUBS=1 D SET1
- I $D(^ORD(100.05,PSJZI,4,PSJZIIEN,2,0)) S PSJSUBS=2 D SET1
- I $D(^ORD(100.05,PSJZI,4,PSJZIIEN,3,0)) S PSJSUBS=3 D SET1
- I $D(^ORD(100.05,PSJZI,5,0)) S PSJSUBS=5 D SET2
- I $D(^ORD(100.05,PSJZI,11,0)) S ^TMP("PSODAOC",$J,"ALLERGY",PSJACNT,"PHARM")=^ORD(100.05,PSJZI,11,0)
- ;WILL NEED TO SET PHARM INFO 100.05
- Q
- ;
- SET1 ;
- F PSJACNT2=0:0 S PSJACNT2=$O(^ORD(100.05,PSJZI,4,PSJZIIEN,PSJSUBS,PSJACNT2)) Q:PSJACNT2'?1N.N D
- .I $D(^ORD(100.05,PSJZI,4,PSJZIIEN,PSJSUBS,PSJACNT2,0)) D
- ..S ^TMP("PSODAOC",$J,"ALLERGY",PSJACNT,4,PSJZIIEN,PSJSUBS,PSJACNT2,0)=^ORD(100.05,PSJZI,4,PSJZIIEN,PSJSUBS,PSJACNT2,0)
- Q
- ;
- SET2 ;
- F PSJACNT2=0:0 S PSJACNT2=$O(^ORD(100.05,PSJZI,PSJSUBS,PSJACNT2)) Q:PSJACNT2'?1N.N D
- .I $D(^ORD(100.05,PSJZI,PSJSUBS,PSJACNT2,0)) D
- ..S ^TMP("PSODAOC",$J,"ALLERGY",PSJACNT,"ALLERGY DD",PSJSUBS,PSJACNT2,0)=^ORD(100.05,PSJZI,PSJSUBS,PSJACNT2,0)
- Q
- ;
- GETORD(PSJSUBS,PSJORDR,PSJTRUE) ;
- I PSJORDR["U"!(PSJORDR["V") D
- .I $D(PSJIEN70(100.11,"1,"_PSJSUBS_",",.01,"I")) S PSJRETI=PSJIEN70(100.11,"1,"_PSJSUBS_",",.01,"I") S:PSJORDR=($P(PSJRETI,";",2)_$P(PSJRETI,";")) PSJTRUE=1 Q
- .I $D(PSJIEN70(100.07,"1,"_PSJSUBS_",",.01,"I")) S PSJRETI=PSJIEN70(100.07,"1,"_PSJSUBS_",",.01,"I") S:PSJORDR=($P(PSJRETI,";",2)_$P(PSJRETI,";")) PSJTRUE=1
- I PSJORDR["P"!(PSJORDR["N") D
- .I $D(PSJIEN60(100.517,"1,"_PSJSUBS_",",.01,"I")) S PSJRETI=PSJIEN60(100.517,"1,"_PSJSUBS_",",.01,"I") I PSJRETI["PS(53.1" S:+PSJORDR=$P(PSJRETI,";") PSJTRUE=1 Q
- .I $D(PSJIEN60(100.07,"1,"_PSJSUBS_",",.01,"I")) S PSJRETI=PSJIEN60(100.07,"1,"_PSJSUBS_",",.01,"I") I PSJRETI["PS(53.1" S:+PSJORDR=$P(PSJRETI,";") PSJTRUE=1
- Q PSJTRUE
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJNEWOA 4908 printed Mar 13, 2025@21:12:42 Page 2
- PSJNEWOA ;BIR/SAB - STORES BACKDOOR ORDER CHECKS IN FILE #100.05 ;11/08/2012
- +1 ;;5.0;INPATIENT MEDICATIONS;**281**;16 DEC 97;Build 113
- +2 ;External reference to ^TMP("PSODAOC",$J is supported by DBIA# 6071
- +3 ;External reference to GETOC4^OROCAPI1 supported by DBIA 5729
- +4 ;External reference to ^ORD(100.05 supported by DBIA 5731
- +5 ;External reference to ^PS(55 supported by DBIA 2191
- +6 ;
- +7 ;Inpatient: When verifying order within the same session, pull allergies from non-verified order to verified order
- +8 ;called from VF1^PSJLIACT and PSJHL3
- VF ;unit dose or pending
- +1 if '$GET(^TMP("PSODAOC",$JOB,"IP IEN"))
- QUIT
- +2 NEW PSJORET,PSJZORN,RXORDER,PSJDGVER,PSJOORD,ON55
- +3 SET (PSJZORN,PSJORET,PSJOORD,PSJORET)=""
- SET PSJDGVER=1
- SET PSJOORD=$GET(^TMP("PSODAOC",$JOB,"IP IEN"))
- +4 IF $GET(PSJSPEED)
- SET PSJOORD=$GET(ON55)
- +5 SET (ON55,RXORDER)=$GET(^TMP("PSODAOC",$JOB,"IP NEW IEN"))
- +6 DO VF2
- +7 QUIT
- VF1 ;IV or edit
- +1 NEW PSJDGORD,PSJORET,PSJZORN,RXORDER,ON55
- +2 IF $GET(PSIVCOPY)
- IF ($GET(ON55)["V")
- KILL ^TMP("PSODAOC",$JOB,"ALLERGY")
- +3 SET (PSJZORN,PSJORET)=""
- SET (ON55,RXORDER)=$GET(^TMP("PSODAOC",$JOB,"IP NEW IEN"))
- +4 SET PSJDGORD=$GET(^TMP("PSODAOC",$JOB,"IP IEN"))
- VF2 ;
- +1 IF $GET(PSJDGVER)&($GET(PSJOORD))
- Begin DoDot:1
- +2 IF PSJOORD["P"!(PSJOORD["N")
- SET PSJZORN=+$PIECE(^PS(53.1,+PSJOORD,0),U,21)
- QUIT
- End DoDot:1
- +3 ;
- +4 IF '$GET(PSJREN)&('$GET(PSJDGVER))&($GET(PSJDGORD))
- Begin DoDot:1
- +5 IF PSJDGORD["P"!(PSJDGORD["N")
- SET PSJZORN=+$PIECE($GET(^PS(53.1,+PSJDGORD,0)),U,21)
- QUIT
- +6 SET PSJZORN=$SELECT(PSJDGORD["V":$PIECE($GET(^PS(55,DFN,"IV",+PSJDGORD,0)),"^",21),PSJDGORD["U":$PIECE($GET(^PS(55,DFN,5,+PSJDGORD,0)),"^",21),1:"")
- End DoDot:1
- +7 IF $GET(PSJREN)&('$GET(PSJDGVER))&($GET(PSJDGORD))
- SET PSJZORN=$SELECT(PSJDGORD["V":$PIECE($GET(^PS(55,DFN,"IV",+PSJDGORD,0)),"^",21),PSJDGORD["U":$PIECE($GET(^PS(55,DFN,5,+PSJDGORD,0)),"^",21),1:"")
- +8 if 'PSJZORN
- QUIT
- +9 DO GETOC4^OROCAPI1(PSJZORN,.PSJORET)
- +10 IF $ORDER(PSJORET(PSJZORN,"DATA",""))=""
- KILL ^TMP("PSODAOC",$JOB)
- QUIT
- +11 ;
- VF3 ;
- +1 NEW PSJZI,PSJZIIEN,PSJNRET,PSJACNT,PSJACNT1,PSJACNT2,PSJIEN60,PSJIEN70,PSJRETI,PSJDFLAG,PSJZERO,PSOZH,PSJOZI
- +2 SET (PSJACNT,PSJACNT1)=0
- +3 FOR PSJZI=0:0
- SET PSJZI=$ORDER(PSJORET(PSJZORN,"DATA",PSJZI))
- if 'PSJZI
- QUIT
- IF $DATA(PSJORET(PSJZORN,"DATA",PSJZI,1))
- Begin DoDot:1
- +4 if +$PIECE(PSJORET(PSJZORN,"DATA",PSJZI,1),";",2)'=3
- QUIT
- +5 KILL PSJAIENS
- +6 IF $GET(PSJOZI)'=PSJZI
- SET PSJZIIEN=0
- +7 SET PSJOZI=PSJZI
- SET PSJACNT=PSJACNT+1
- +8 FOR
- SET PSJZIIEN=$ORDER(^ORD(100.05,PSJZI,4,PSJZIIEN))
- if PSJZIIEN=""
- QUIT
- IF $DATA(^ORD(100.05,PSJZI,4,PSJZIIEN,0))
- Begin DoDot:2
- +9 if $PIECE(^ORD(100.05,PSJZI,0),"^",3)["CPRS"
- QUIT
- +10 DO GETS^DIQ(100.05,PSJZI,"60*","I","PSJIEN60")
- DO GETS^DIQ(100.05,PSJZI,"70*","I","PSJIEN70")
- +11 SET PSJDFLAG=""
- SET PSJDFLAG=$$GETORD(PSJZI,$SELECT($GET(PSJDGVER):$GET(PSJOORD),1:PSJDGORD),PSJDFLAG)
- +12 if '$GET(PSJDFLAG)
- QUIT
- +13 ;
- +14 SET PSJACNT1=PSJACNT1+1
- +15 SET ^TMP("PSODAOC",$JOB,"ALLERGY",PSJACNT,"ALLERGY PKG")="IP^"_$SELECT($GET(PSJOCFG)]"":$PIECE(PSJOCFG," ")_" ",1:"")_"^"_ON55_"^"_PSJZORN
- +16 ;S:$D(^ORD(100.05,PSJZI,8)) ^TMP("PSODAOC",$J,"ALLERGY",PSJACNT,"INTERVENTION")=^ORD(100.05,PSJZI,8)
- +17 SET ^TMP("PSODAOC",$JOB,"ALLERGY","PROVR")=$GET(PSJORET(PSJZI,"DATA",PSJZIIEN,"OR",1,0))
- +18 ;
- +19 DO SETTMP
- End DoDot:2
- End DoDot:1
- +20 ;
- VF4 ;
- +1 SET PSOZH="Allergy"
- SET RXORDER=ON55
- SET PSJAOC1=1
- +2 SET (ON55,RXORDER)=$GET(^TMP("PSODAOC",$JOB,"IP NEW IEN"))
- +3 IF $DATA(^TMP("PSODAOC",$JOB,"ALLERGY"))
- DO VF2^PSJNEWOC
- +4 KILL ^TMP("PSODAOC",$JOB,"ALLERGY")
- +5 QUIT
- +6 ;
- SETTMP ;
- +1 NEW PSJSUBS,PSJACNT2
- +2 SET ^TMP("PSODAOC",$JOB,"ALLERGY",PSJACNT,4,PSJZIIEN,0)=$GET(^ORD(100.05,PSJZI,4,PSJZIIEN,0))
- +3 ;
- +4 IF $DATA(^ORD(100.05,PSJZI,4,PSJZIIEN,1,0))
- SET PSJSUBS=1
- DO SET1
- +5 IF $DATA(^ORD(100.05,PSJZI,4,PSJZIIEN,2,0))
- SET PSJSUBS=2
- DO SET1
- +6 IF $DATA(^ORD(100.05,PSJZI,4,PSJZIIEN,3,0))
- SET PSJSUBS=3
- DO SET1
- +7 IF $DATA(^ORD(100.05,PSJZI,5,0))
- SET PSJSUBS=5
- DO SET2
- +8 IF $DATA(^ORD(100.05,PSJZI,11,0))
- SET ^TMP("PSODAOC",$JOB,"ALLERGY",PSJACNT,"PHARM")=^ORD(100.05,PSJZI,11,0)
- +9 ;WILL NEED TO SET PHARM INFO 100.05
- +10 QUIT
- +11 ;
- SET1 ;
- +1 FOR PSJACNT2=0:0
- SET PSJACNT2=$ORDER(^ORD(100.05,PSJZI,4,PSJZIIEN,PSJSUBS,PSJACNT2))
- if PSJACNT2'?1N.N
- QUIT
- Begin DoDot:1
- +2 IF $DATA(^ORD(100.05,PSJZI,4,PSJZIIEN,PSJSUBS,PSJACNT2,0))
- Begin DoDot:2
- +3 SET ^TMP("PSODAOC",$JOB,"ALLERGY",PSJACNT,4,PSJZIIEN,PSJSUBS,PSJACNT2,0)=^ORD(100.05,PSJZI,4,PSJZIIEN,PSJSUBS,PSJACNT2,0)
- End DoDot:2
- End DoDot:1
- +4 QUIT
- +5 ;
- SET2 ;
- +1 FOR PSJACNT2=0:0
- SET PSJACNT2=$ORDER(^ORD(100.05,PSJZI,PSJSUBS,PSJACNT2))
- if PSJACNT2'?1N.N
- QUIT
- Begin DoDot:1
- +2 IF $DATA(^ORD(100.05,PSJZI,PSJSUBS,PSJACNT2,0))
- Begin DoDot:2
- +3 SET ^TMP("PSODAOC",$JOB,"ALLERGY",PSJACNT,"ALLERGY DD",PSJSUBS,PSJACNT2,0)=^ORD(100.05,PSJZI,PSJSUBS,PSJACNT2,0)
- End DoDot:2
- End DoDot:1
- +4 QUIT
- +5 ;
- GETORD(PSJSUBS,PSJORDR,PSJTRUE) ;
- +1 IF PSJORDR["U"!(PSJORDR["V")
- Begin DoDot:1
- +2 IF $DATA(PSJIEN70(100.11,"1,"_PSJSUBS_",",.01,"I"))
- SET PSJRETI=PSJIEN70(100.11,"1,"_PSJSUBS_",",.01,"I")
- if PSJORDR=($PIECE(PSJRETI,";",2)_$PIECE(PSJRETI,";"))
- SET PSJTRUE=1
- QUIT
- +3 IF $DATA(PSJIEN70(100.07,"1,"_PSJSUBS_",",.01,"I"))
- SET PSJRETI=PSJIEN70(100.07,"1,"_PSJSUBS_",",.01,"I")
- if PSJORDR=($PIECE(PSJRETI,";",2)_$PIECE(PSJRETI,";"))
- SET PSJTRUE=1
- End DoDot:1
- +4 IF PSJORDR["P"!(PSJORDR["N")
- Begin DoDot:1
- +5 IF $DATA(PSJIEN60(100.517,"1,"_PSJSUBS_",",.01,"I"))
- SET PSJRETI=PSJIEN60(100.517,"1,"_PSJSUBS_",",.01,"I")
- IF PSJRETI["PS(53.1"
- if +PSJORDR=$PIECE(PSJRETI,";")
- SET PSJTRUE=1
- QUIT
- +6 IF $DATA(PSJIEN60(100.07,"1,"_PSJSUBS_",",.01,"I"))
- SET PSJRETI=PSJIEN60(100.07,"1,"_PSJSUBS_",",.01,"I")
- IF PSJRETI["PS(53.1"
- if +PSJORDR=$PIECE(PSJRETI,";")
- SET PSJTRUE=1
- End DoDot:1
- +7 QUIT PSJTRUE
