- PSORN52C ;BIR/SAB-files renewal entries con't ;05-Nov-2013 17:30;DU
- ;;7.0;OUTPATIENT PHARMACY;**1,7,11,27,46,75,87,100,111,124,117,131,146,1003,1011,148,200,225,1015,1017**;DEC 1997;Build 40
- ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
- ; Modified - IHS/CIA/PLS - 01/07/04 - Line PSORN52C+14
- ; 08/09/04 - Line ORC+20
- ; IHS/MSC/PLS - 04/18/11 - Line PSORN52C+16 and PRVDATA EP
- S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("NRX #") K DD,DO
- D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO
- D:+$G(DGI) TECH^PSODGDGI ; L +^PSRX(PSOX("IRXN")):0
- D:$G(^TMP("PSODAI",$J,0))
- .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1
- .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F S DAI=$O(^TMP("PSODAI",$J,DAI)) Q:'DAI D
- ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0)
- ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1
- .K ^TMP("PSODAI",$J),DAI
- S PSORN52(PSOX("IRXN"),0)=PSOX("NRX0"),PSORN52(PSOX("IRXN"),2)=PSOX("NRX2"),PSORN52(PSOX("IRXN"),3)=PSOX("NRX3")
- S PSORN52(PSOX("IRXN"),"EPH")=PSOX("EPH")
- S PSORN52(PSOX("IRXN"),9999999)=PSOX("NRX9999999") ; IHS/CIA/PLS - 01/07/04
- D PRVDATA
- S:'$G(PSOX("ENT")) PSORN52(PSOX("IRXN"),"SIG")=PSOX("SIG")
- S PSORN52(PSOX("IRXN"),"STA")=PSOX("STA")
- S:$G(PSOX("TN"))]"" PSORN52(PSOX("IRXN"),"TN")=PSOX("TN")
- I $G(PSOX("METHOD OF PICK-UP"))]"",PSOX("FILL DATE")'>DT S PSORN52(PSOX("IRXN"),"MP")=PSOX("METHOD OF PICK-UP")
- S PSORN52(PSOX("IRXN"),"TYPE")=0
- S PSOX1="" F S PSOX1=$O(PSORN52(PSOX("IRXN"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSORN52(PSOX("IRXN"),PSOX1))
- I $O(SIG(0)) D G ENT
- .S II=0 F I=0:0 S I=$O(SIG(I)) Q:'I S ^PSRX(PSOX("IRXN"),"SIG1",I,0)=SIG(I),II=II+1
- .S ^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^"_II_"^"_II,$P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1 K I,II
- .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1
- ENT S ^PSRX(PSOX("IRXN"),"POE")=1,^PSRX(PSOX("IRXN"),"INS")=$G(PSOX("INS"))
- I $G(OR0) S:$P(OR0,"^",24) ^PSRX(PSOX("IRXN"),"PKI")=1
- I $G(PSOX("SIG",1))]"",'$O(PSOX("SIG",1)) S ^PSRX(PSOX("IRXN"),"INS1",1,0)=PSOX("SIG",1),^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^1^1^"_DT_"^^"
- I $O(^PSRX(PSOX("OIRXN"),"INS1",0)) D
- .F D=0:0 S D=$O(^PSRX(PSOX("OIRXN"),"INS1",D)) Q:'D S ^PSRX(PSOX("IRXN"),"INS1",D,0)=^PSRX(PSOX("OIRXN"),"INS1",D,0)
- .S ^PSRX(PSOX("IRXN"),"INS1",0)=^PSRX(PSOX("OIRXN"),"INS1",0)
- TNT F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(PSOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_"^" D
- .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATION",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PSOX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I))
- .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
- S:$G(PSOX("ENT")) ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
- Q
- ORC ;
- D MARK^PSOTPCAN
- K PSORDEDT,GG,PSOHD,PSOID,PTST,PTDY,PTRF,RFCNT,RN,SEG1,SIG,SIGOK,DIC
- K ST0,STA,STP,STR,JJ,LSI,MM,ORDG,ORIG,PHARMST,PSCAN,PSCNT,PSOI,GMRAL,DIC,DIE,HDR,IEN,NAME D KVA^VADPT
- I $G(PSOFDR) D
- .I $G(PKI1)=1,$G(PKIR)]"" D ACT^PSOPKIV1(PSOX("IRXN"))
- .S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",2)=$P(OR0,"^"),^PSRX("APL",$P(OR0,"^"),PSOX("IRXN"))=""
- .I $P($G(^PS(52.41,+$G(ORD),"EXT")),"^")="" I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) K:'$G(PSOPRC) PRC K PHI
- .I $O(PRC(0)) S T=0 F S T=$O(PRC(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
- .I $O(PHI(0)) S T=0 F S T=$O(PHI(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
- .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) D S PSOI=1 Q
- ..S POERR("PLACER")=$P(^PS(52.41,ORD,0),"^"),PSORDEDT=ORD
- ..K ^PS(52.41,"AOR",PSODFN,+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
- ..S DA=ORD,DIK="^PS(52.41," D ^DIK
- ..S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI"))
- .E S $P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$P(OR0,"^",8)
- .D PSOUL^PSSLOCK(ORD_"S") S DIK="^PS(52.41,",DA=ORD D ^DIK K DIK,DA
- I $G(PSOX("OIRXN")),'$G(COPY) S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",3)=PSOX("OIRXN"),$P(^PSRX(PSOX("OIRXN"),"OR1"),"^",4)=PSOX("IRXN"),^PSRX("AQ",PSOX("IRXN"),PSOX("OIRXN"))="" K PRC
- I $O(PRC(0)) S T=0 F S T=$O(PRC(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T),^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
- I $O(PHI(0)) S T=0 F S T=$O(PHI(T)) Q:'T S ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T),^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
- ;IHS/CIA/PLS - 08/09/05 - Added support for the Automated Dispensing Interface.
- ; Change will set Finishing Person to Clerk and not the person tasking the Automated Interface.
- ;S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=DUZ
- S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=$S($G(BOPDFN):$G(PSOX("CLERK CODE")),1:DUZ)
- S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",8)=$$NOW^XLFDT D
- . N DA,DIK S DA=PSOX("IRXN"),DIK="^PSRX(",DIK(1)=38.3 D EN1^DIK K DIK,DA
- S PHARMST="",$P(^PSRX(PSOX("IRXN"),"OR1"),"^")=$G(PSODRUG("OI"))
- S RXN=PSOX("IRXN") D SAVE
- S STAT=$S($G(OR0)]""&('$G(PSOI)):"SC",$G(PSOI):"RO",1:"SN") S PHARMST=$S('$G(PSORX("VERIFY")):"CM",1:"IP") ;D EN^PSOHLSN1(RXN,STAT,PHARMST,"",PSONOOR)
- S ^TMP("PSORXN",$J,RXN)=STAT_"^"_PHARMST_"^"_PSONOOR D PSOL^PSSLOCK(RXN)
- D RESTORE K PSORDEDT,PHI,PRC,STAT,COMM,PSOI,OR2,OR1,PHARMST,RXN,DRG,STA,ACT,OCXR,OCXD1,OCXDT,OCXI
- Q
- BBRX ;build bingo board Rx array; called by PSON52,PSOR52,PSORN52
- I $G(BBRX(1))']"" S BBRX(1)=PSOX("IRXN")_"," Q
- F PSOX1=0:0 S PSOX1=$O(BBRX(PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
- I $L(BBRX(PSOX2))+$L(PSOX("IRXN"))<220 S BBRX(PSOX2)=BBRX(PSOX2)_PSOX("IRXN")_","
- E S BBRX(PSOX2+1)=PSOX("IRXN")_","
- Q
- SAVE ;this module will be used to save PSO arrays
- K ^TMP("PSOLST",$J) F I=0:0 S I=$O(PSOLST(I)) Q:'I S ^TMP("PSOLST",$J,I,0)=PSOLST(I)
- K ^TMP("PSOSD",$J) S (STA,DRG)="" F S STA=$O(PSOSD(STA)) Q:STA="" F S DRG=$O(PSOSD(STA,DRG)) Q:DRG="" S ^TMP("PSOSD",$J,STA,DRG)=PSOSD(STA,DRG)
- I $G(PSOSD) S ^TMP("PSOSD",$J,0)=PSOSD
- I $G(PSODRUG("NAME"))]"" K ^TMP("PSODRUG",$J) S STA="" F S STA=$O(PSODRUG(STA)) Q:STA="" S ^TMP("PSODRUG",$J,STA)=PSODRUG(STA)
- I $G(PSOX("# OF REFILLS"))]"" K ^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J) D
- .S STA="" F S STA=$O(PSOX(STA)) Q:STA="" S ^TMP("PSOX",$J,STA)=$G(PSOX(STA)) D
- ..I STA="OLD LAST RX#",$O(PSOX(STA,"")) K ^TMP("PSOX",$J,STA) S ^TMP("PSOX",$J,STA,$O(PSOX(STA,"")))=PSOX(STA,$O(PSOX(STA,""))) D Q
- ...I $O(PSONEW(STA,"")) S ^TMP("PSONEW",$J,STA,$O(PSONEW(STA,"")))=PSONEW(STA,$O(PSONEW(STA,"")))
- ...I $O(PSORENW(STA,"")) S ^TMP("PSORENW",$J,STA,$O(PSORENW(STA,"")))=PSORENW(STA,$O(PSORENW(STA,"")))
- ...I $O(PSORXED(STA,"")) S ^TMP("PSORXED",$J,STA,$O(PSORXED(STA,"")))=PSORXED(STA,$O(PSORXED(STA,"")))
- ..F ACT="PSORENW","PSONEW","PSORXED" I $G(@(ACT_"("""_STA_""")"))]"" S ^TMP(ACT,$J,STA)=@(ACT_"("""_STA_""")")
- K PSOPTPST,PSOSD,PSONEW,PSOLST,PSORENW,PSORXED,PSODRUG
- Q
- RESTORE ;this module restore saved arrays
- S STA=0 F S STA=$O(^TMP("PSOLST",$J,STA)) Q:'STA S PSOLST(STA)=^TMP("PSOLST",$J,STA,0)
- I $G(^TMP("PSOSD",$J,0)) S PSOSD=$G(^TMP("PSOSD",$J,0))
- S (STA,DRG)="" F S STA=$O(^TMP("PSOSD",$J,STA)) Q:STA="" F S DRG=$O(^TMP("PSOSD",$J,STA,DRG)) Q:DRG="" S PSOSD(STA,DRG)=^TMP("PSOSD",$J,STA,DRG)
- S STA="" F S STA=$O(^TMP("PSODRUG",$J,STA)) Q:STA="" S PSODRUG(STA)=^TMP("PSODRUG",$J,STA)
- S STA="" F ACT="PSOX","PSORENW","PSONEW","PSORXED" D:$O(^TMP(ACT,$J,STA))]""
- .F S STA=$O(^TMP(ACT,$J,STA)) Q:STA="" I STA'="OLD LAST RX#" S @(ACT_"("""_STA_""")")=^TMP(ACT,$J,STA)
- I $O(^TMP("PSOX",$J,"OLD LAST RX#","")) S PSOX("OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))=^TMP("PSOX",$J,"OLD LAST RX#",$O(^TMP("PSOX",$J,"OLD LAST RX#","")))
- I $O(^TMP("PSONEW",$J,"OLD LAST RX#","")) S PSONEW("OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))=^TMP("PSONEW",$J,"OLD LAST RX#",$O(^TMP("PSONEW",$J,"OLD LAST RX#","")))
- I $O(^TMP("PSORENW",$J,"OLD LAST RX#","")) S PSORENW("OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))=^TMP("PSORENW",$J,"OLD LAST RX#",$O(^TMP("PSORENW",$J,"OLD LAST RX#","")))
- I $O(^TMP("PSORXED",$J,"OLD LAST RX#","")) S PSORXED("OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))=^TMP("PSORXED",$J,"OLD LAST RX#",$O(^TMP("PSORXED",$J,"OLD LAST RX#","")))
- K ^TMP("PSOSD",$J),^TMP("PSODRUG",$J),^TMP("PSOX",$J),^TMP("PSORENW",$J),^TMP("PSONEW",$J),^TMP("PSORXED",$J),^TMP("PSOLST",$J)
- Q
- ; Populate PSORN52(PSOX("IRXN"),999999931) node
- PRVDATA ; EP -
- S $P(PSORN52(PSOX("IRXN"),999999931),U)=PSOX("PRV STR ADD1")
- S $P(PSORN52(PSOX("IRXN"),999999931),U,2)=PSOX("PRV STR ADD2")
- S $P(PSORN52(PSOX("IRXN"),999999931),U,3)=PSOX("PRV STR ADD3")
- S $P(PSORN52(PSOX("IRXN"),999999931),U,4)=PSOX("PRV CITY")
- S $P(PSORN52(PSOX("IRXN"),999999931),U,5)=PSOX("PRV STATE")
- S $P(PSORN52(PSOX("IRXN"),999999931),U,6)=PSOX("PRV ZIP")
- S $P(PSORN52(PSOX("IRXN"),999999931),U,7)=PSOX("DEA_VA_USPHS")
- ;IHS/MSC/MGH patch 1017 Add RxNorm
- S $P(PSORN52(PSOX("IRXN"),999999921),U,7)=PSOX("RXNORM")
- Q
- PSORN52C ;BIR/SAB-files renewal entries con't ;05-Nov-2013 17:30;DU
- +1 ;;7.0;OUTPATIENT PHARMACY;**1,7,11,27,46,75,87,100,111,124,117,131,146,1003,1011,148,200,225,1015,1017**;DEC 1997;Build 40
- +2 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
- +3 ; Modified - IHS/CIA/PLS - 01/07/04 - Line PSORN52C+14
- +4 ; 08/09/04 - Line ORC+20
- +5 ; IHS/MSC/PLS - 04/18/11 - Line PSORN52C+16 and PRVDATA EP
- +6 SET DIC="^PSRX("
- SET DLAYGO=52
- SET DIC(0)="L"
- SET X=PSOX("NRX #")
- KILL DD,DO
- +7 DO FILE^DICN
- SET PSOX("IRXN")=+Y
- KILL DLAYGO,X,Y,DIC,DD,DO
- +8 ; L +^PSRX(PSOX("IRXN")):0
- IF +$GET(DGI)
- DO TECH^PSODGDGI
- +9 IF $GET(^TMP("PSODAI",$JOB,0))
- Begin DoDot:1
- +10 SET $PIECE(^PSRX(PSOX("IRXN"),3),"^",6)=1
- +11 IF $ORDER(^TMP("PSODAI",$JOB,0))
- SET DAI=0
- FOR
- SET DAI=$ORDER(^TMP("PSODAI",$JOB,DAI))
- IF 'DAI
- QUIT
- Begin DoDot:2
- +12 IF '$DATA(^PSRX(PSOX("IRXN"),"DAI",0))
- SET ^PSRX(PSOX("IRXN"),"DAI",0)="^52.03^^"
- SET ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$JOB,DAI,0)
- +13 SET $PIECE(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$PIECE(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)+1
- SET $PIECE(^(0),"^",4)=+$PIECE(^(0),"^",4)+1
- End DoDot:2
- +14 KILL ^TMP("PSODAI",$JOB),DAI
- End DoDot:1
- +15 SET PSORN52(PSOX("IRXN"),0)=PSOX("NRX0")
- SET PSORN52(PSOX("IRXN"),2)=PSOX("NRX2")
- SET PSORN52(PSOX("IRXN"),3)=PSOX("NRX3")
- +16 SET PSORN52(PSOX("IRXN"),"EPH")=PSOX("EPH")
- +17 ; IHS/CIA/PLS - 01/07/04
- SET PSORN52(PSOX("IRXN"),9999999)=PSOX("NRX9999999")
- +18 DO PRVDATA
- +19 IF '$GET(PSOX("ENT"))
- SET PSORN52(PSOX("IRXN"),"SIG")=PSOX("SIG")
- +20 SET PSORN52(PSOX("IRXN"),"STA")=PSOX("STA")
- +21 IF $GET(PSOX("TN"))]""
- SET PSORN52(PSOX("IRXN"),"TN")=PSOX("TN")
- +22 IF $GET(PSOX("METHOD OF PICK-UP"))]""
- IF PSOX("FILL DATE")'>DT
- SET PSORN52(PSOX("IRXN"),"MP")=PSOX("METHOD OF PICK-UP")
- +23 SET PSORN52(PSOX("IRXN"),"TYPE")=0
- +24 SET PSOX1=""
- FOR
- SET PSOX1=$ORDER(PSORN52(PSOX("IRXN"),PSOX1))
- IF PSOX1=""
- QUIT
- SET ^PSRX(PSOX("IRXN"),PSOX1)=$GET(PSORN52(PSOX("IRXN"),PSOX1))
- +25 IF $ORDER(SIG(0))
- Begin DoDot:1
- +26 SET II=0
- FOR I=0:0
- SET I=$ORDER(SIG(I))
- IF 'I
- QUIT
- SET ^PSRX(PSOX("IRXN"),"SIG1",I,0)=SIG(I)
- SET II=II+1
- +27 SET ^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^"_II_"^"_II
- SET $PIECE(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1
- KILL I,II
- +28 SET $PIECE(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1
- End DoDot:1
- GOTO ENT
- ENT SET ^PSRX(PSOX("IRXN"),"POE")=1
- SET ^PSRX(PSOX("IRXN"),"INS")=$GET(PSOX("INS"))
- +1 IF $GET(OR0)
- IF $PIECE(OR0,"^",24)
- SET ^PSRX(PSOX("IRXN"),"PKI")=1
- +2 IF $GET(PSOX("SIG",1))]""
- IF '$ORDER(PSOX("SIG",1))
- SET ^PSRX(PSOX("IRXN"),"INS1",1,0)=PSOX("SIG",1)
- SET ^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^1^1^"_DT_"^^"
- +3 IF $ORDER(^PSRX(PSOX("OIRXN"),"INS1",0))
- Begin DoDot:1
- +4 FOR D=0:0
- SET D=$ORDER(^PSRX(PSOX("OIRXN"),"INS1",D))
- IF 'D
- QUIT
- SET ^PSRX(PSOX("IRXN"),"INS1",D,0)=^PSRX(PSOX("OIRXN"),"INS1",D,0)
- +5 SET ^PSRX(PSOX("IRXN"),"INS1",0)=^PSRX(PSOX("OIRXN"),"INS1",0)
- End DoDot:1
- TNT FOR I=1:1:PSOX("ENT")
- SET ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$GET(PSOX("DOSE ORDERED",I))_"^"_$GET(PSOX("UNITS",I))_"^"_$GET(PSOX("NOUN",I))_"^"
- Begin DoDot:1
- +1 SET ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$GET(PSOX("DURATION",I))_"^"_$GET(PSOX("CONJUNCTION",I))_"^"_$GET(PSOX("ROUTE",I))_"^"_$GET(PSOX("SCHEDULE",I))_"^"_$GET(PSOX("VERB",I))
- +2 IF $GET(PSOX("ODOSE",I))]""
- SET ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
- End DoDot:1
- +3 IF $GET(PSOX("ENT"))
- SET ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
- +4 QUIT
- ORC ;
- +1 DO MARK^PSOTPCAN
- +2 KILL PSORDEDT,GG,PSOHD,PSOID,PTST,PTDY,PTRF,RFCNT,RN,SEG1,SIG,SIGOK,DIC
- +3 KILL ST0,STA,STP,STR,JJ,LSI,MM,ORDG,ORIG,PHARMST,PSCAN,PSCNT,PSOI,GMRAL,DIC,DIE,HDR,IEN,NAME
- DO KVA^VADPT
- +4 IF $GET(PSOFDR)
- Begin DoDot:1
- +5 IF $GET(PKI1)=1
- IF $GET(PKIR)]""
- DO ACT^PSOPKIV1(PSOX("IRXN"))
- +6 SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^",2)=$PIECE(OR0,"^")
- SET ^PSRX("APL",$PIECE(OR0,"^"),PSOX("IRXN"))=""
- +7 IF $PIECE($GET(^PS(52.41,+$GET(ORD),"EXT")),"^")=""
- IF $GET(PSOSIGFL)!($GET(PSODRUG("OI"))'=$PIECE(OR0,"^",8))
- IF '$GET(PSOPRC)
- KILL PRC
- KILL PHI
- +8 IF $ORDER(PRC(0))
- SET T=0
- FOR
- SET T=$ORDER(PRC(T))
- IF 'T
- QUIT
- SET ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T)
- SET ^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
- +9 IF $ORDER(PHI(0))
- SET T=0
- FOR
- SET T=$ORDER(PHI(T))
- IF 'T
- QUIT
- SET ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T)
- SET ^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
- +10 IF $GET(PSOSIGFL)!($GET(PSODRUG("OI"))'=$PIECE(OR0,"^",8))
- Begin DoDot:2
- +11 SET POERR("PLACER")=$PIECE(^PS(52.41,ORD,0),"^")
- SET PSORDEDT=ORD
- +12 KILL ^PS(52.41,"AOR",PSODFN,+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD)
- +13 SET DA=ORD
- SET DIK="^PS(52.41,"
- DO ^DIK
- +14 SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^")=$GET(PSODRUG("OI"))
- End DoDot:2
- SET PSOI=1
- QUIT
- +15 IF '$TEST
- SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^")=$PIECE(OR0,"^",8)
- +16 DO PSOUL^PSSLOCK(ORD_"S")
- SET DIK="^PS(52.41,"
- SET DA=ORD
- DO ^DIK
- KILL DIK,DA
- End DoDot:1
- +17 IF $GET(PSOX("OIRXN"))
- IF '$GET(COPY)
- SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^",3)=PSOX("OIRXN")
- SET $PIECE(^PSRX(PSOX("OIRXN"),"OR1"),"^",4)=PSOX("IRXN")
- SET ^PSRX("AQ",PSOX("IRXN"),PSOX("OIRXN"))=""
- KILL PRC
- +18 IF $ORDER(PRC(0))
- SET T=0
- FOR
- SET T=$ORDER(PRC(T))
- IF 'T
- QUIT
- SET ^PSRX(PSOX("IRXN"),"PRC",T,0)=PRC(T)
- SET ^PSRX(PSOX("IRXN"),"PRC",0)="^^"_T_"^"_T_"^"_DT_"^"
- +19 IF $ORDER(PHI(0))
- SET T=0
- FOR
- SET T=$ORDER(PHI(T))
- IF 'T
- QUIT
- SET ^PSRX(PSOX("IRXN"),"PI",T,0)=PHI(T)
- SET ^PSRX(PSOX("IRXN"),"PI",0)="^^"_T_"^"_T_"^"_DT_"^"
- +20 ;IHS/CIA/PLS - 08/09/05 - Added support for the Automated Dispensing Interface.
- +21 ; Change will set Finishing Person to Clerk and not the person tasking the Automated Interface.
- +22 ;S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=DUZ
- +23 SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=$SELECT($GET(BOPDFN):$GET(PSOX("CLERK CODE")),1:DUZ)
- +24 SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^",8)=$$NOW^XLFDT
- Begin DoDot:1
- +25 NEW DA,DIK
- SET DA=PSOX("IRXN")
- SET DIK="^PSRX("
- SET DIK(1)=38.3
- DO EN1^DIK
- KILL DIK,DA
- End DoDot:1
- +26 SET PHARMST=""
- SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^")=$GET(PSODRUG("OI"))
- +27 SET RXN=PSOX("IRXN")
- DO SAVE
- +28 ;D EN^PSOHLSN1(RXN,STAT,PHARMST,"",PSONOOR)
- SET STAT=$SELECT($GET(OR0)]""&('$GET(PSOI)):"SC",$GET(PSOI):"RO",1:"SN")
- SET PHARMST=$SELECT('$GET(PSORX("VERIFY")):"CM",1:"IP")
- +29 SET ^TMP("PSORXN",$JOB,RXN)=STAT_"^"_PHARMST_"^"_PSONOOR
- DO PSOL^PSSLOCK(RXN)
- +30 DO RESTORE
- KILL PSORDEDT,PHI,PRC,STAT,COMM,PSOI,OR2,OR1,PHARMST,RXN,DRG,STA,ACT,OCXR,OCXD1,OCXDT,OCXI
- +31 QUIT
- BBRX ;build bingo board Rx array; called by PSON52,PSOR52,PSORN52
- +1 IF $GET(BBRX(1))']""
- SET BBRX(1)=PSOX("IRXN")_","
- QUIT
- +2 FOR PSOX1=0:0
- SET PSOX1=$ORDER(BBRX(PSOX1))
- IF 'PSOX1
- QUIT
- SET PSOX2=PSOX1
- +3 IF $LENGTH(BBRX(PSOX2))+$LENGTH(PSOX("IRXN"))<220
- SET BBRX(PSOX2)=BBRX(PSOX2)_PSOX("IRXN")_","
- +4 IF '$TEST
- SET BBRX(PSOX2+1)=PSOX("IRXN")_","
- +5 QUIT
- SAVE ;this module will be used to save PSO arrays
- +1 KILL ^TMP("PSOLST",$JOB)
- FOR I=0:0
- SET I=$ORDER(PSOLST(I))
- IF 'I
- QUIT
- SET ^TMP("PSOLST",$JOB,I,0)=PSOLST(I)
- +2 KILL ^TMP("PSOSD",$JOB)
- SET (STA,DRG)=""
- FOR
- SET STA=$ORDER(PSOSD(STA))
- IF STA=""
- QUIT
- FOR
- SET DRG=$ORDER(PSOSD(STA,DRG))
- IF DRG=""
- QUIT
- SET ^TMP("PSOSD",$JOB,STA,DRG)=PSOSD(STA,DRG)
- +3 IF $GET(PSOSD)
- SET ^TMP("PSOSD",$JOB,0)=PSOSD
- +4 IF $GET(PSODRUG("NAME"))]""
- KILL ^TMP("PSODRUG",$JOB)
- SET STA=""
- FOR
- SET STA=$ORDER(PSODRUG(STA))
- IF STA=""
- QUIT
- SET ^TMP("PSODRUG",$JOB,STA)=PSODRUG(STA)
- +5 IF $GET(PSOX("# OF REFILLS"))]""
- KILL ^TMP("PSOX",$JOB),^TMP("PSORENW",$JOB),^TMP("PSONEW",$JOB),^TMP("PSORXED",$JOB)
- Begin DoDot:1
- +6 SET STA=""
- FOR
- SET STA=$ORDER(PSOX(STA))
- IF STA=""
- QUIT
- SET ^TMP("PSOX",$JOB,STA)=$GET(PSOX(STA))
- Begin DoDot:2
- +7 IF STA="OLD LAST RX#"
- IF $ORDER(PSOX(STA,""))
- KILL ^TMP("PSOX",$JOB,STA)
- SET ^TMP("PSOX",$JOB,STA,$ORDER(PSOX(STA,"")))=PSOX(STA,$ORDER(PSOX(STA,"")))
- Begin DoDot:3
- +8 IF $ORDER(PSONEW(STA,""))
- SET ^TMP("PSONEW",$JOB,STA,$ORDER(PSONEW(STA,"")))=PSONEW(STA,$ORDER(PSONEW(STA,"")))
- +9 IF $ORDER(PSORENW(STA,""))
- SET ^TMP("PSORENW",$JOB,STA,$ORDER(PSORENW(STA,"")))=PSORENW(STA,$ORDER(PSORENW(STA,"")))
- +10 IF $ORDER(PSORXED(STA,""))
- SET ^TMP("PSORXED",$JOB,STA,$ORDER(PSORXED(STA,"")))=PSORXED(STA,$ORDER(PSORXED(STA,"")))
- End DoDot:3
- QUIT
- +11 FOR ACT="PSORENW","PSONEW","PSORXED"
- IF $GET(@(ACT_"("""_STA_""")"))]""
- SET ^TMP(ACT,$JOB,STA)=@(ACT_"("""_STA_""")")
- End DoDot:2
- End DoDot:1
- +12 KILL PSOPTPST,PSOSD,PSONEW,PSOLST,PSORENW,PSORXED,PSODRUG
- +13 QUIT
- RESTORE ;this module restore saved arrays
- +1 SET STA=0
- FOR
- SET STA=$ORDER(^TMP("PSOLST",$JOB,STA))
- IF 'STA
- QUIT
- SET PSOLST(STA)=^TMP("PSOLST",$JOB,STA,0)
- +2 IF $GET(^TMP("PSOSD",$JOB,0))
- SET PSOSD=$GET(^TMP("PSOSD",$JOB,0))
- +3 SET (STA,DRG)=""
- FOR
- SET STA=$ORDER(^TMP("PSOSD",$JOB,STA))
- IF STA=""
- QUIT
- FOR
- SET DRG=$ORDER(^TMP("PSOSD",$JOB,STA,DRG))
- IF DRG=""
- QUIT
- SET PSOSD(STA,DRG)=^TMP("PSOSD",$JOB,STA,DRG)
- +4 SET STA=""
- FOR
- SET STA=$ORDER(^TMP("PSODRUG",$JOB,STA))
- IF STA=""
- QUIT
- SET PSODRUG(STA)=^TMP("PSODRUG",$JOB,STA)
- +5 SET STA=""
- FOR ACT="PSOX","PSORENW","PSONEW","PSORXED"
- IF $ORDER(^TMP(ACT,$JOB,STA))]""
- Begin DoDot:1
- +6 FOR
- SET STA=$ORDER(^TMP(ACT,$JOB,STA))
- IF STA=""
- QUIT
- IF STA'="OLD LAST RX#"
- SET @(ACT_"("""_STA_""")")=^TMP(ACT,$JOB,STA)
- End DoDot:1
- +7 IF $ORDER(^TMP("PSOX",$JOB,"OLD LAST RX#",""))
- SET PSOX("OLD LAST RX#",$ORDER(^TMP("PSOX",$JOB,"OLD LAST RX#","")))=^TMP("PSOX",$JOB,"OLD LAST RX#",$ORDER(^TMP("PSOX",$JOB,"OLD LAST RX#","")))
- +8 IF $ORDER(^TMP("PSONEW",$JOB,"OLD LAST RX#",""))
- SET PSONEW("OLD LAST RX#",$ORDER(^TMP("PSONEW",$JOB,"OLD LAST RX#","")))=^TMP("PSONEW",$JOB,"OLD LAST RX#",$ORDER(^TMP("PSONEW",$JOB,"OLD LAST RX#","")))
- +9 IF $ORDER(^TMP("PSORENW",$JOB,"OLD LAST RX#",""))
- SET PSORENW("OLD LAST RX#",$ORDER(^TMP("PSORENW",$JOB,"OLD LAST RX#","")))=^TMP("PSORENW",$JOB,"OLD LAST RX#",$ORDER(^TMP("PSORENW",$JOB,"OLD LAST RX#","")))
- +10 IF $ORDER(^TMP("PSORXED",$JOB,"OLD LAST RX#",""))
- SET PSORXED("OLD LAST RX#",$ORDER(^TMP("PSORXED",$JOB,"OLD LAST RX#","")))=^TMP("PSORXED",$JOB,"OLD LAST RX#",$ORDER(^TMP("PSORXED",$JOB,"OLD LAST RX#","")))
- +11 KILL ^TMP("PSOSD",$JOB),^TMP("PSODRUG",$JOB),^TMP("PSOX",$JOB),^TMP("PSORENW",$JOB),^TMP("PSONEW",$JOB),^TMP("PSORXED",$JOB),^TMP("PSOLST",$JOB)
- +12 QUIT
- +13 ; Populate PSORN52(PSOX("IRXN"),999999931) node
- PRVDATA ; EP -
- +1 SET $PIECE(PSORN52(PSOX("IRXN"),999999931),U)=PSOX("PRV STR ADD1")
- +2 SET $PIECE(PSORN52(PSOX("IRXN"),999999931),U,2)=PSOX("PRV STR ADD2")
- +3 SET $PIECE(PSORN52(PSOX("IRXN"),999999931),U,3)=PSOX("PRV STR ADD3")
- +4 SET $PIECE(PSORN52(PSOX("IRXN"),999999931),U,4)=PSOX("PRV CITY")
- +5 SET $PIECE(PSORN52(PSOX("IRXN"),999999931),U,5)=PSOX("PRV STATE")
- +6 SET $PIECE(PSORN52(PSOX("IRXN"),999999931),U,6)=PSOX("PRV ZIP")
- +7 SET $PIECE(PSORN52(PSOX("IRXN"),999999931),U,7)=PSOX("DEA_VA_USPHS")
- +8 ;IHS/MSC/MGH patch 1017 Add RxNorm
- +9 SET $PIECE(PSORN52(PSOX("IRXN"),999999921),U,7)=PSOX("RXNORM")
- +10 QUIT
