PSORN52C ;BIR/SAB - files renewal entries con't ;Oct 20, 2022@16:32
;;7.0;OUTPATIENT PHARMACY;**1,7,11,27,46,75,87,100,111,124,117,131,146,148,200,225,251,387,379,391,617,441,545,753**;DEC 1997;Build 53
;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
;External reference to $$DS^PSSDSAPI supported by DBIA 5425
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^PSODGDGP ; 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:'$G(PSOX("ENT")) PSORN52(PSOX("IRXN"),"SIG")=PSOX("SIG")
I '$D(^XUSEC("PSORPH",DUZ)),$$DS^PSSDSAPI&(+$G(^TMP("PSODOSF",$J,0))) S PSOX("STA")=1
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 $P(^PSRX(PSOX("IRXN"),7),"^",2)=$G(PSOX("MAIL EXEMPTION")) ;p753
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) D
. I $P(OR0,"^",24) S $P(^PSRX(PSOX("IRXN"),"PKI"),1,3)="1^^" D ACLOG Q
. N ORDIEN S ORDIEN=$O(^PS(52.41,"B",$P(OR0,"^"),0))
. I $P($G(PSOX("CS")),"^"),ORDIEN,$$ERXIEN^PSOERXUT(ORDIEN_"P"),$$GET1^DIQ(52.49,$$ERXIEN^PSOERXUT(ORDIEN_"P"),95.1,"I") D Q
. . S $P(^PSRX(PSOX("IRXN"),"PKI"),"^",1,3)="^^1"
I $P($G(PSOX("CS")),"^"),'+$P($G(^PSRX(PSOX("IRXN"),"PKI")),"^"),'+$P($G(^PSRX(PSOX("IRXN"),"PKI")),"^",3) D
. S $P(^PSRX(PSOX("IRXN"),"PKI"),"^",2)=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)
S:$P($G(^PSRX(PSOX("OIRXN"),"IND")),"^")]"" ^PSRX(PSOX("IRXN"),"IND")=^PSRX(PSOX("OIRXN"),"IND") ;*441-IND
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")
S:$G(^PSRX(PSOX("OIRXN"),6.5)) ^PSRX(PSOX("IRXN"),6.5)=^PSRX(PSOX("OIRXN"),6.5)
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_"^"
S $P(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=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
;*545 - Store the selected DEA#
I $G(PSORX("RXDEA"))]"" S ^TMP("PSORXN",$J,RXN,"DEA")=PSORX("RXDEA")
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="" D
.Q:STA="BAD"
.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
;
ACLOG ;activity log (digitally signed CS orders)
N DTTM,CNT,OCNT,XX
D NOW^%DTC S DTTM=%
S CNT=0 F XX=0:0 S XX=$O(^PSRX(PSOX("IRXN"),"A",XX)) Q:'XX S CNT=XX
S OCNT=CNT
I $G(PSOCSP("NAME"))'=PSODRUG("NAME") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^NAME: "_PSOCSP("NAME")
S XX=0 F S XX=$O(PSOCSP("DOSE",XX)) Q:'XX I PSOCSP("DOSE",XX)'=$G(PSORENW("DOSE",XX)) D
.S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DOSAGE: "_PSOCSP("DOSE",XX)
S XX=0 F S XX=$O(PSOCSP("DOSE ORDERED",XX)) Q:'XX I PSOCSP("DOSE ORDERED",XX)'=$G(PSORENW("DOSE ORDERED",XX)) D
.S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DISPENSE UNITS: "_PSOCSP("DOSE ORDERED",XX)
I $G(PSOCSP("ISSUE DATE"))'=PSORENW("ISSUE DATE") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ISSUE DATE: "_$$FMTE^XLFDT(PSOCSP("ISSUE DATE"))
I $G(PSOCSP("DAYS SUPPLY"))'=PSORENW("DAYS SUPPLY") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DAYS SUPPLY: "_PSOCSP("DAYS SUPPLY")
I $G(PSOCSP("QTY"))'=PSORENW("QTY") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^QTY: "_PSOCSP("QTY")
I $G(PSOCSP("# OF REFILLS"))'=PSORENW("# OF REFILLS") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^# OF REFILLS: "_PSOCSP("# OF REFILLS")
I '$$SUBSCRIB^ORDEA($P(OR0,"^"),PSOX("IRXN")) S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ORDER DEA ARCHIVE INFO file entry failure"
I OCNT'=CNT S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^"_CNT_"^"_CNT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORN52C 10506 printed Nov 22, 2024@17:44:06 Page 2
PSORN52C ;BIR/SAB - files renewal entries con't ;Oct 20, 2022@16:32
+1 ;;7.0;OUTPATIENT PHARMACY;**1,7,11,27,46,75,87,100,111,124,117,131,146,148,200,225,251,387,379,391,617,441,545,753**;DEC 1997;Build 53
+2 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+3 ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
+4 SET DIC="^PSRX("
SET DLAYGO=52
SET DIC(0)="L"
SET X=PSOX("NRX #")
KILL DD,DO
+5 DO FILE^DICN
SET PSOX("IRXN")=+Y
KILL DLAYGO,X,Y,DIC,DD,DO
+6 ; L +^PSRX(PSOX("IRXN")):0
if +$GET(DGI)
DO TECH^PSODGDGP
+7 if $GET(^TMP("PSODAI",$JOB,0))
Begin DoDot:1
+8 SET $PIECE(^PSRX(PSOX("IRXN"),3),"^",6)=1
+9 IF $ORDER(^TMP("PSODAI",$JOB,0))
SET DAI=0
FOR
SET DAI=$ORDER(^TMP("PSODAI",$JOB,DAI))
if 'DAI
QUIT
Begin DoDot:2
+10 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)
+11 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
+12 KILL ^TMP("PSODAI",$JOB),DAI
End DoDot:1
+13 SET PSORN52(PSOX("IRXN"),0)=PSOX("NRX0")
SET PSORN52(PSOX("IRXN"),2)=PSOX("NRX2")
SET PSORN52(PSOX("IRXN"),3)=PSOX("NRX3")
+14 SET PSORN52(PSOX("IRXN"),"EPH")=PSOX("EPH")
+15 if '$GET(PSOX("ENT"))
SET PSORN52(PSOX("IRXN"),"SIG")=PSOX("SIG")
+16 IF '$DATA(^XUSEC("PSORPH",DUZ))
IF $$DS^PSSDSAPI&(+$GET(^TMP("PSODOSF",$JOB,0)))
SET PSOX("STA")=1
+17 SET PSORN52(PSOX("IRXN"),"STA")=PSOX("STA")
+18 if $GET(PSOX("TN"))]""
SET PSORN52(PSOX("IRXN"),"TN")=PSOX("TN")
+19 IF $GET(PSOX("METHOD OF PICK-UP"))]""
IF PSOX("FILL DATE")'>DT
SET PSORN52(PSOX("IRXN"),"MP")=PSOX("METHOD OF PICK-UP")
+20 SET PSORN52(PSOX("IRXN"),"TYPE")=0
+21 ;p753
SET $PIECE(^PSRX(PSOX("IRXN"),7),"^",2)=$GET(PSOX("MAIL EXEMPTION"))
+22 SET PSOX1=""
FOR
SET PSOX1=$ORDER(PSORN52(PSOX("IRXN"),PSOX1))
if PSOX1=""
QUIT
SET ^PSRX(PSOX("IRXN"),PSOX1)=$GET(PSORN52(PSOX("IRXN"),PSOX1))
+23 IF $ORDER(SIG(0))
Begin DoDot:1
+24 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
+25 SET ^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^"_II_"^"_II
SET $PIECE(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1
KILL I,II
+26 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)
Begin DoDot:1
+2 IF $PIECE(OR0,"^",24)
SET $PIECE(^PSRX(PSOX("IRXN"),"PKI"),1,3)="1^^"
DO ACLOG
QUIT
+3 NEW ORDIEN
SET ORDIEN=$ORDER(^PS(52.41,"B",$PIECE(OR0,"^"),0))
+4 IF $PIECE($GET(PSOX("CS")),"^")
IF ORDIEN
IF $$ERXIEN^PSOERXUT(ORDIEN_"P")
IF $$GET1^DIQ(52.49,$$ERXIEN^PSOERXUT(ORDIEN_"P"),95.1,"I")
Begin DoDot:2
+5 SET $PIECE(^PSRX(PSOX("IRXN"),"PKI"),"^",1,3)="^^1"
End DoDot:2
QUIT
End DoDot:1
+6 IF $PIECE($GET(PSOX("CS")),"^")
IF '+$PIECE($GET(^PSRX(PSOX("IRXN"),"PKI")),"^")
IF '+$PIECE($GET(^PSRX(PSOX("IRXN"),"PKI")),"^",3)
Begin DoDot:1
+7 SET $PIECE(^PSRX(PSOX("IRXN"),"PKI"),"^",2)=1
End DoDot:1
+8 ;
+9 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_"^^"
+10 IF $ORDER(^PSRX(PSOX("OIRXN"),"INS1",0))
Begin DoDot:1
+11 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)
+12 SET ^PSRX(PSOX("IRXN"),"INS1",0)=^PSRX(PSOX("OIRXN"),"INS1",0)
End DoDot:1
+13 ;*441-IND
if $PIECE($GET(^PSRX(PSOX("OIRXN"),"IND")),"^")]""
SET ^PSRX(PSOX("IRXN"),"IND")=^PSRX(PSOX("OIRXN"),"IND")
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 if $GET(^PSRX(PSOX("OIRXN"),6.5))
SET ^PSRX(PSOX("IRXN"),6.5)=^PSRX(PSOX("OIRXN"),6.5)
+5 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 SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^",5)=DUZ
+21 SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^",8)=$$NOW^XLFDT
Begin DoDot:1
+22 NEW DA,DIK
SET DA=PSOX("IRXN")
SET DIK="^PSRX("
SET DIK(1)=38.3
DO EN1^DIK
KILL DIK,DA
End DoDot:1
+23 SET PHARMST=""
SET $PIECE(^PSRX(PSOX("IRXN"),"OR1"),"^")=$GET(PSODRUG("OI"))
+24 SET RXN=PSOX("IRXN")
DO SAVE
+25 ;*545 - Store the selected DEA#
+26 IF $GET(PSORX("RXDEA"))]""
SET ^TMP("PSORXN",$JOB,RXN,"DEA")=PSORX("RXDEA")
+27 ;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")
+28 SET ^TMP("PSORXN",$JOB,RXN)=STAT_"^"_PHARMST_"^"_PSONOOR
DO PSOL^PSSLOCK(RXN)
+29 DO RESTORE
KILL PSORDEDT,PHI,PRC,STAT,COMM,PSOI,OR2,OR1,PHARMST,RXN,DRG,STA,ACT,OCXR,OCXD1,OCXDT,OCXI
+30 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
Begin DoDot:1
+5 if STA="BAD"
QUIT
+6 SET ^TMP("PSODRUG",$JOB,STA)=PSODRUG(STA)
End DoDot:1
+7 IF $GET(PSOX("# OF REFILLS"))]""
KILL ^TMP("PSOX",$JOB),^TMP("PSORENW",$JOB),^TMP("PSONEW",$JOB),^TMP("PSORXED",$JOB)
Begin DoDot:1
+8 SET STA=""
FOR
SET STA=$ORDER(PSOX(STA))
if STA=""
QUIT
SET ^TMP("PSOX",$JOB,STA)=$GET(PSOX(STA))
Begin DoDot:2
+9 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
+10 IF $ORDER(PSONEW(STA,""))
SET ^TMP("PSONEW",$JOB,STA,$ORDER(PSONEW(STA,"")))=PSONEW(STA,$ORDER(PSONEW(STA,"")))
+11 IF $ORDER(PSORENW(STA,""))
SET ^TMP("PSORENW",$JOB,STA,$ORDER(PSORENW(STA,"")))=PSORENW(STA,$ORDER(PSORENW(STA,"")))
+12 IF $ORDER(PSORXED(STA,""))
SET ^TMP("PSORXED",$JOB,STA,$ORDER(PSORXED(STA,"")))=PSORXED(STA,$ORDER(PSORXED(STA,"")))
End DoDot:3
QUIT
+13 FOR ACT="PSORENW","PSONEW","PSORXED"
IF $GET(@(ACT_"("""_STA_""")"))]""
SET ^TMP(ACT,$JOB,STA)=@(ACT_"("""_STA_""")")
End DoDot:2
End DoDot:1
+14 KILL PSOPTPST,PSOSD,PSONEW,PSOLST,PSORENW,PSORXED,PSODRUG
+15 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 ;
ACLOG ;activity log (digitally signed CS orders)
+1 NEW DTTM,CNT,OCNT,XX
+2 DO NOW^%DTC
SET DTTM=%
+3 SET CNT=0
FOR XX=0:0
SET XX=$ORDER(^PSRX(PSOX("IRXN"),"A",XX))
if 'XX
QUIT
SET CNT=XX
+4 SET OCNT=CNT
+5 IF $GET(PSOCSP("NAME"))'=PSODRUG("NAME")
SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^NAME: "_PSOCSP("NAME")
+6 SET XX=0
FOR
SET XX=$ORDER(PSOCSP("DOSE",XX))
if 'XX
QUIT
IF PSOCSP("DOSE",XX)'=$GET(PSORENW("DOSE",XX))
Begin DoDot:1
+7 SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DOSAGE: "_PSOCSP("DOSE",XX)
End DoDot:1
+8 SET XX=0
FOR
SET XX=$ORDER(PSOCSP("DOSE ORDERED",XX))
if 'XX
QUIT
IF PSOCSP("DOSE ORDERED",XX)'=$GET(PSORENW("DOSE ORDERED",XX))
Begin DoDot:1
+9 SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DISPENSE UNITS: "_PSOCSP("DOSE ORDERED",XX)
End DoDot:1
+10 IF $GET(PSOCSP("ISSUE DATE"))'=PSORENW("ISSUE DATE")
SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ISSUE DATE: "_$$FMTE^XLFDT(PSOCSP("ISSUE DATE"))
+11 IF $GET(PSOCSP("DAYS SUPPLY"))'=PSORENW("DAYS SUPPLY")
SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DAYS SUPPLY: "_PSOCSP("DAYS SUPPLY")
+12 IF $GET(PSOCSP("QTY"))'=PSORENW("QTY")
SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^QTY: "_PSOCSP("QTY")
+13 IF $GET(PSOCSP("# OF REFILLS"))'=PSORENW("# OF REFILLS")
SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^# OF REFILLS: "_PSOCSP("# OF REFILLS")
+14 IF '$$SUBSCRIB^ORDEA($PIECE(OR0,"^"),PSOX("IRXN"))
SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ORDER DEA ARCHIVE INFO file entry failure"
+15 IF OCNT'=CNT
SET ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^"_CNT_"^"_CNT
+16 QUIT
+17 ;
