PSON52 ;BIR/DSD - files new entries in prescription file ;Jan 20, 2022@11:18:18
;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157,143,219,148,239,201,268,260,225,303,358,251,387,379,390,391,313,408,473,504,505,517,457,617,562,441,746,753,769**;DEC 1997;Build 26
;External reference ^PS(55 supported by DBIA 2228
;External reference to PSOUL^PSSLOCK supported by DBIA 2789
;External reference to ^XUSEC supported by DBIA 10076
;External reference SWSTAT^IBBAPI supported by DBIA 4663
;External reference SAVNDC^PSSNDCUT supported by DBIA 4707
;External reference to $$DS^PSSDSAPI supported by DBIA 5425
EN(PSOX) ;Entry Point
START ;
D:$D(XRTL) T0^%ZOSV ; Start RT Monitor
D INIT G:PSON52("QFLG") END D NFILE Q:$G(PSONEW("DFLG"))
D PS55,DIK
S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor
D FINISH
; If parked, set PARK level, APARK xref, activity log, and remove from label queue and suspense 441 PAPI
I $G(PSOX("MAIL/WINDOW"))="P" D PARK^PSOPRKA(PSOX("IRXN")),RMP^PSOPRKA(PSOX("IRXN"))
I $P(^PSRX(PSOX("IRXN"),0),"^",11)="W",$G(^("IB")) S ^PSRX("ACP",$P(^PSRX(PSOX("IRXN"),0),"^",2),$P(^(2),"^",2),0,PSOX("IRXN"))=""
END D EOJ
Q
INIT ;
K X,%DT S:$G(PSOID) PSOX("ISSUE DATE")=PSOID
S PSOX("CS")=0 K PSOX("NOPSDRPH")
F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)="" I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOX("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOX("CS"),"^",2)=1
I $P($G(PSOX("CS")),"^"),'$D(^XUSEC("PSDRPH",DUZ)) S PSOX("NOPSDRPH")=1
S PSON52("QFLG")=0,X1=PSOX("ISSUE DATE"),X2=PSOX("DAYS SUPPLY")*(PSOX("# OF REFILLS")+1)\1
I $D(CLOZPAT) S X2=$S(X2=14:14,X2=7:7,1:X2) G DT
S X2=$S(PSOX("DAYS SUPPLY")=X2:X2,+$G(PSOX("CS")):184,+$G(DEA("CS")):184,1:366)
I X2<30 D
. N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
. S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
DT D C^%DTC S PSOX("STOP DATE")=$P(X,".") K X
;*473 - If Calculated Exp. Date < Fill Date with No refills, reset Exp.
I '$D(CLOZPAT),'PSOX("# OF REFILLS"),PSOX("FILL DATE")>PSOX("STOP DATE") D
. N EXP S EXP=$$FMADD^XLFDT(PSOX("FILL DATE"),PSOX("DAYS SUPPLY"))
. I $$FMDIFF^XLFDT(EXP,PSOX("ISSUE DATE"))>$S(+$G(PSOX("CS")):184,1:366) D
. . S EXP=$$FMADD^XLFDT(PSOX("ISSUE DATE"),$S(+$G(PSOX("CS")):184,1:366))
. I EXP<PSOX("FILL DATE") S EXP=PSOX("FILL DATE")
. S PSOX("STOP DATE")=EXP
; Titration to Maintenance Rx Conversion - Set Maint. Rx Exp. Date = Original Rx Exp. Date
I $G(PSOTITRX) D
. S PSOX("STOP DATE")=$$GET1^DIQ(52,PSOTITRX,26,"I")
I PSOX("# OF REFILLS")>0 S X1=PSOX("FILL DATE"),X2=$S((PSOX("DAYS SUPPLY")-10\1)<1:1,1:PSOX("DAYS SUPPLY")-10\1) D C^%DTC S PSOX("NEXT POSSIBLE REFILL")=$P(X,".") K X
S PSOX("TYPE OF RX")=0,PSOX("DISPENSED DATE")=PSOX("FILL DATE") D NOW^%DTC S PSOX("LOGIN DATE")=$S($P($G(OR0),"^",12):$P($G(OR0),"^",12),1:%) K %,X
S PSOX("STATUS")=$S($G(PSOX("STATUS"))]"":PSOX("STATUS"),$D(PSORX("VERIFY")):1,$D(PSOX("NOPSDRPH")):1,1:0)
S PSOX("COPIES")=$S($G(PSOX("COPIES"))]"":PSOX("COPIES"),1:1)
I $G(PSORX("PHARM"))]"" S PSOX("PHARMACIST")=PSORX("PHARM") K PSORX("PHARM")
INITX Q
;
NFILE I $G(OR0) D Q:$G(PSONEW("DFLG"))
.D NOOR^PSONEW Q:$G(PSONEW("DFLG"))
.I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) S PSONEW("CLERK CODE")=DUZ,PSONEW("REMARKS")=$G(PSONEW("REMARKS"))_" CPRS Order #"_$P(OR0,"^")_" Edited."
S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("RX #") K DD,DO D FILE^DICN S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO
I '$D(^XUSEC("PSORPH",DUZ))!($D(PSOX("NOPSDRPH"))),$$DS^PSSDSAPI&(+$G(^TMP("PSODOSF",$J,0))) S PSON52(PSOX("IRXN"),"STA")=1,PSOX("STATUS")=1
F PSOX1=0:1 S PSON52=$P($T(DD+PSOX1),";;",2,4) Q:PSON52="" K PSOY S PSOY=$P(PSON52,";;") I $G(@PSOY)]"" S $P(PSON52(PSOX("IRXN"),$P(PSON52,";;",2)),"^",$P(PSON52,";;",3))=@PSOY
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 ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
;*441-IND
I $G(PSOX("IND"))]"" S ^PSRX(PSOX("IRXN"),"IND")=PSOX("IND")_$S($G(PSOX("INDF")):"^"_PSOX("INDF"),1:"") S:$G(PSOX("INDO"))]"" $P(^PSRX(PSOX("IRXN"),"IND"),"^",3)=PSOX("INDO")
K PSOX1,PSOY
S PSOX1="" F S PSOX1=$O(PSON52(PSOX("IRXN"),PSOX1)) Q:PSOX1="" S ^PSRX(PSOX("IRXN"),PSOX1)=$G(PSON52(PSOX("IRXN"),PSOX1))
; PSO*7*505 - quantity check - leading zeros
N QTYTMP
S QTYTMP=$P(^PSRX(PSOX("IRXN"),0),U,7)
I QTYTMP["." D
.Q:$P(QTYTMP,".")'=""
.;Q:$P(QTYTMP,".")=0
.S $P(^PSRX(PSOX("IRXN"),0),U,7)=0_QTYTMP
; PSO*7*505 - end quantity check - leading zeros
I $O(PSOX("SIG",0)) D
.S D=0 F S D=$O(PSOX("SIG",D)) Q:'D S ^PSRX(PSOX("IRXN"),"INS1",D,0)=PSOX("SIG",D),TP=$G(TP)+1
.S ^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^"_TP_"^"_TP_"^"_DT_"^^" K TP,D
I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")
I $G(SIGOK) D
.S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1,^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^^"
.S D=0 F S D=$O(SIG(D)) Q:'D S ^PSRX(PSOX("IRXN"),"SIG1",D,0)=SIG(D),$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 Q:'$O(SIG(D))
.K SIG
I $D(PSOINSFL) S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^1^1",^PSRX(PSOX("IRXN"),"A",1,0)=DT_"^G^^0^Patient Instructions "_$S(PSOINSFL=1:"",1:"Not ")_"Sent By Provider."
I $G(PSOTITRF) D ;PSO*441 - marked in CPRS
.S $P(^PSRX(PSOX("IRXN"),"TIT"),"^",3)=1,COMM="MARKED as Titration"
.D RXACT^PSOBPSU2(PSOX("IRXN"),,COMM,"K",PSONEW("CLERK CODE"))
I $G(OR0) D
. ; Allow CS from eRX to proceed without OR0|24 being set
. N ERXIEN,PSCSERX S ERXIEN=$$ERXIEN^PSOERXUT($G(ORD)_"P"),PSCSERX=0
. I ERXIEN,$$GET1^DIQ(52.49,ERXIEN,95.1,"I"),$$CS^PSOERXA0(+$$GET1^DIQ(52.49,ERXIEN,3.2,"I")) S PSCSERX=1
. ;Allow processing to continue if ERX order and is a CS without $P(OR0,"^",24)
. I $P(OR0,"^",24)!PSCSERX S $P(^PSRX(PSOX("IRXN"),"PKI"),"^",1,3)=$S($G(PSOSIGFL):"^1^",1:"1^^") D ACLOG
. 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
. . 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
K PSOX1,PSOFINFL,HLDSIG,D,PSOINSFL,D
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
I $G(PSOX("CHCS NUMBER"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^")=$G(PSOX("CHCS NUMBER"))
I $G(PSOX("EXTERNAL SYSTEM"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^",2)=$G(PSOX("EXTERNAL SYSTEM"))
I $G(PSOX("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=$G(PSOX("NEWCOPAY"))
;Next line, set SC question based on Copay status?
IBQ ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,1:1)
N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))_"^"_$G(PSOANSQ("SHAD"))
I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1) D
. S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD ;don't set if SC % is null or 0, just set it in ICD node
D ICD^PSODIAG
D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
D:$G(PSOTITRX) SAVETIT(PSOTITRX,PSOX("IRXN"))
K PSOTITRX,PSOANSQ,PSOANSQD,PSOX("NEWCOPAY")
L -^PSRX("B",PSOX("IRXN"))
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(PSONEW("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(PSONEW("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 PSOCSP("ISSUE DATE")'=PSONEW("ISSUE DATE") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ISSUE DATE: "_$$FMTE^XLFDT(PSOCSP("ISSUE DATE"))
I PSOCSP("DAYS SUPPLY")'=PSONEW("DAYS SUPPLY") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DAYS SUPPLY: "_PSOCSP("DAYS SUPPLY")
I PSOCSP("QTY")'=PSONEW("QTY") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^QTY: "_PSOCSP("QTY")
I PSOCSP("# OF REFILLS")'=PSONEW("# 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
;
PS55 ;
L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^"
F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1))
S PSOX("55 IEN")=PSOX1
S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1)
S ^PS(55,PSODFN,"P","A",PSONEW("STOP DATE"),PSOX("IRXN"))=""
PS55X L -^PS(55,PSODFN,"P")
K PSOX1
Q
DIK ;
I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR
I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="100.2////"_PSOMAILX D ^DIE K DIE,DR ;p753
K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK
S DA=PSOX("IRXN") D ORC^PSORN52C
Q
FINISH ;
ANQ I $G(ANQDATA)]"" D NOW^%DTC H 1 G:$D(^PS(52.52,"B",%)) ANQ D
.K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=% D FILE^DICN K DIC,DLAYGO,DD,DO
.S ^PS(52.52,+Y,0)=$P(Y,"^",2)_"^"_PSOX("IRXN")_"^"_ANQDATA,^PS(52.52,"A",PSOX("IRXN"),+Y)="" K X,Y,%,ANQREM
;PSO 457 Added H 1 to line tag ANQ
; ** START NCC REMEDIATION ** 457/RTW RJS
I $D(ANQDATA) D ;ADD ADDITIONAL LOGIC FOR ORDERING PROVIDER RJS/457
.I $P($G(ANQDATA),"^",2)["UNKNOWN",$D(PSOX("PROVIDER")) S $P(ANQDATA,"^",2)=PSOX("PROVIDER")
.I $D(PSOX("PROVIDER")),$P($G(ANQDATA),"^",2)'=PSOX("PROVIDER") S $P(ANQDATA,"^",2)=PSOX("PROVIDER")
I $G(ANQDATA)]"" N PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK,DTM D NOW^%DTC S DTM=% G:$$FIND1^DIC(52.52,,"X",DTM) ANQ D
.S PSOUSER=$P(ANQDATA,"^",2),PSO1PH=$P(ANQDATA,"^"),PSO2PH=$P(ANQDATA,"^",5)
.S PSOREASN=$P(ANQDATA,"^",3),PSOREMRK=$P(ANQDATA,"^",4)
.K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=DTM
.D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
.N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////^S X=PSOX(""IRXN"")"_";2////^S X=PSO1PH;3////^S X=PSOUSER;4////^S X=PSOREASN;5////^S X=PSOREMRK;6////^S X=PSO2PH"
.D ^DIE K DIE,DA,DR
.K X,Y,%,ANQREM
.D ALERT^PSORENW0
I $$GET1^DIQ(50,+$G(PSODRUG("IEN")),17.5)="PSOCLO1" D ^YSCLTST6
;/RBN END MODIFICATIONS FOR PSO*7.0*457
;
N PSOTFIN
I $D(PSOX("NOPSDRPH"))!('$D(^XUSEC("PSORPH",DUZ))) S PSOTFIN="",PSOTFIN=$$TECH2^PSODGDGP(PSOX("IRXN"),PSODFN,DUZ,.PSOX)
I $D(PSOX("NOPSDRPH"))!('$D(^XUSEC("PSORPH",DUZ))) G FINISHP:$G(PSOTFIN)=1 G FINISHX:$G(PSOTFIN)=2
;
I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IRXN"))=0 D SUS^PSORXL K DA G FINISHX
;
; - Calling ECME for claims generation and transmission / REJECT handling
N ACTION,PSOERX
S PSOERX=PSOX("IRXN")
I ($G(PSOX("MAIL/WINDOW"))'="P"),($$SUBMIT^PSOBPSUT(PSOERX,0)) D I ACTION="Q"!(ACTION="^") Q ;441 PAPI
. S ACTION="" D ECMESND^PSOBPSU1(PSOERX,0,"","OF")
. ; Quit if there is an unresolved Tricare/CHAMPVA non-billable reject code, PSO*7*358
. I $$PSOET^PSOREJP3(PSOERX,0) S ACTION="Q" Q
. I $$FIND^PSOREJUT(PSOERX,0) D
. . S ACTION=$$HDLG^PSOREJU1(PSOERX,0,"79,88,943","OF","IOQ","Q")
. I $$STATUS^PSOBPSUT(PSOERX,0)="E PAYABLE" D
. . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,0))
;
FINISHP ;
I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX("IRXN"))=0 G FINISHX
F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
E S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
S RXFL(PSOX("IRXN"))=0
FINISHX ;call to build Rx array for bingo board
I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^PSORN52C
K PSOX1,PSOX2
K ^TMP("PSODGI",$J),^TMP("PSOSER",$J),^TMP("PSOSERS",$J),^TMP("PSODGS",$J),^TMP("PSOTDD",$J),^TMP("PSODOSF",$J)
Q
;
SAVETIT(TITRX,MNTRX) ; Save Titration/Maintenance dose Rx information
I '$D(^PSRX(+$G(TITRX),0))!'$D(^PSRX(+$G(MNTRX),0)) Q
S $P(^PSRX(TITRX,"TIT"),"^",2,3)=MNTRX_"^1"
D RXACT^PSOBPSU2(TITRX,0,"Maintenance Rx#: "_$$GET1^DIQ(52,MNTRX,.01),"E")
S $P(^PSRX(MNTRX,"TIT"),"^",1)=TITRX
D RXACT^PSOBPSU2(MNTRX,0,"Titration Rx#: "_$$GET1^DIQ(52,TITRX,.01),"E")
Q
;
EOJ ;
;B xref locked in routine PSONRXN
L -^PSRX("B",PSOX("IRXN")) K OTHDOS,DA,PSON52,PSOPRC,RTE,SCH,PSOX("INS"),PSONEW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT
D PSOUL^PSSLOCK(PSOX("IRXN"))
Q
;
;;PSOX("SIG");;SIG;;1
DD ;;PSOX("RX #");;0;;1
;;PSOX("ISSUE DATE");;0;;13
;;PSODFN;;0;;2
;;PSOX("PATIENT STATUS");;0;;3
;;PSOX("PROVIDER");;0;;4
;;PSOX("CLINIC");;0;;5
;;PSODRUG("IEN");;0;;6
;;PSODRUG("TRADE NAME");;TN;;1
;;PSOX("QTY");;0;;7
;;PSOX("DAYS SUPPLY");;0;;8
;;PSOX("# OF REFILLS");;0;;9
;;PSOX("COPIES");;0;;18
;;PSOX("MAIL/WINDOW");;0;;11
;;PSOX("REMARKS");;3;;7
;;PSOX("ADMINCLINIC");;0;;15
;;PSOX("CLERK CODE");;0;;16
;;PSODRUG("COST");;0;;17
;;PSOSITE;;2;;9
;;PSOX("LOGIN DATE");;2;;1
;;PSOX("FILL DATE");;2;;2
;;PSOX("PHARMACIST");;2;;3
;;PSOX("LOT #");;2;;4
;;PSOX("DISPENSED DATE");;2;;5
;;PSOX("STOP DATE");;2;;6
;;PSODRUG("NDC");;2;;7
;;PSODRUG("DAW");;EPH;;1
;;PSODRUG("MANUFACTURER");;2;;8
;;PSOX("EXPIRATION DATE");;2;;11
;;PSOX("GENERIC PROVIDER");;2;;12
;;PSOX("RELEASED DATE/TIME");;2;;13
;;PSOX("METHOD OF PICK-UP");;MP;;1
;;PSOX("STATUS");;STA;;1
;;PSOX("LAST DISPENSED DATE");;3;;1
;;PSOX("NEXT POSSIBLE REFILL");;3;;2
;;PSOX("COSIGNING PROVIDER");;3;;3
;;PSOX("TYPE OF RX");;TYPE;;1
;;PSOX("SAND");;SAND;;1
;;PSOX("POE");;POE;;1
;;PSOX("INS");;INS;;1
;;PSOX("IND");;IND;;1
;;PSOX("INDF");;IND;;2
;;PSOX("INDO");;IND;;3
;;PSOX("MAIL EXEMPTION");;7;;2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSON52 15238 printed Sep 23, 2025@20:07:42 Page 2
PSON52 ;BIR/DSD - files new entries in prescription file ;Jan 20, 2022@11:18:18
+1 ;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157,143,219,148,239,201,268,260,225,303,358,251,387,379,390,391,313,408,473,504,505,517,457,617,562,441,746,753,769**;DEC 1997;Build 26
+2 ;External reference ^PS(55 supported by DBIA 2228
+3 ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
+4 ;External reference to ^XUSEC supported by DBIA 10076
+5 ;External reference SWSTAT^IBBAPI supported by DBIA 4663
+6 ;External reference SAVNDC^PSSNDCUT supported by DBIA 4707
+7 ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
EN(PSOX) ;Entry Point
START ;
+1 ; Start RT Monitor
if $DATA(XRTL)
DO T0^%ZOSV
+2 DO INIT
if PSON52("QFLG")
GOTO END
DO NFILE
if $GET(PSONEW("DFLG"))
QUIT
+3 DO PS55
DO DIK
+4 ; Stop RT Monitor
if $DATA(XRT0)
SET XRTN=$TEXT(+0)
if $DATA(XRT0)
DO T1^%ZOSV
+5 DO FINISH
+6 ; If parked, set PARK level, APARK xref, activity log, and remove from label queue and suspense 441 PAPI
+7 IF $GET(PSOX("MAIL/WINDOW"))="P"
DO PARK^PSOPRKA(PSOX("IRXN"))
DO RMP^PSOPRKA(PSOX("IRXN"))
+8 IF $PIECE(^PSRX(PSOX("IRXN"),0),"^",11)="W"
IF $GET(^("IB"))
SET ^PSRX("ACP",$PIECE(^PSRX(PSOX("IRXN"),0),"^",2),$PIECE(^(2),"^",2),0,PSOX("IRXN"))=""
END DO EOJ
+1 QUIT
INIT ;
+1 KILL X,%DT
if $GET(PSOID)
SET PSOX("ISSUE DATE")=PSOID
+2 SET PSOX("CS")=0
KILL PSOX("NOPSDRPH")
+3 FOR DEA=1:1
if $EXTRACT(PSODRUG("DEA"),DEA)=""
QUIT
IF $EXTRACT(+PSODRUG("DEA"),DEA)>1
IF $EXTRACT(+PSODRUG("DEA"),DEA)<6
SET $PIECE(PSOX("CS"),"^")=1
if $EXTRACT(+PSODRUG("DEA"),DEA)=2
SET $PIECE(PSOX("CS"),"^",2)=1
+4 IF $PIECE($GET(PSOX("CS")),"^")
IF '$DATA(^XUSEC("PSDRPH",DUZ))
SET PSOX("NOPSDRPH")=1
+5 SET PSON52("QFLG")=0
SET X1=PSOX("ISSUE DATE")
SET X2=PSOX("DAYS SUPPLY")*(PSOX("# OF REFILLS")+1)\1
+6 IF $DATA(CLOZPAT)
SET X2=$SELECT(X2=14:14,X2=7:7,1:X2)
GOTO DT
+7 SET X2=$SELECT(PSOX("DAYS SUPPLY")=X2:X2,+$GET(PSOX("CS")):184,+$GET(DEA("CS")):184,1:366)
+8 IF X2<30
Begin DoDot:1
+9 NEW %
SET %=$PIECE($GET(PSORX("PATIENT STATUS")),"^")
SET X2=30
+10 if %?.N
SET %=$PIECE($GET(^PS(53,+%,0)),"^")
IF %["AUTH ABS"
SET X2=5
End DoDot:1
DT DO C^%DTC
SET PSOX("STOP DATE")=$PIECE(X,".")
KILL X
+1 ;*473 - If Calculated Exp. Date < Fill Date with No refills, reset Exp.
+2 IF '$DATA(CLOZPAT)
IF 'PSOX("# OF REFILLS")
IF PSOX("FILL DATE")>PSOX("STOP DATE")
Begin DoDot:1
+3 NEW EXP
SET EXP=$$FMADD^XLFDT(PSOX("FILL DATE"),PSOX("DAYS SUPPLY"))
+4 IF $$FMDIFF^XLFDT(EXP,PSOX("ISSUE DATE"))>$SELECT(+$GET(PSOX("CS")):184,1:366)
Begin DoDot:2
+5 SET EXP=$$FMADD^XLFDT(PSOX("ISSUE DATE"),$SELECT(+$GET(PSOX("CS")):184,1:366))
End DoDot:2
+6 IF EXP<PSOX("FILL DATE")
SET EXP=PSOX("FILL DATE")
+7 SET PSOX("STOP DATE")=EXP
End DoDot:1
+8 ; Titration to Maintenance Rx Conversion - Set Maint. Rx Exp. Date = Original Rx Exp. Date
+9 IF $GET(PSOTITRX)
Begin DoDot:1
+10 SET PSOX("STOP DATE")=$$GET1^DIQ(52,PSOTITRX,26,"I")
End DoDot:1
+11 IF PSOX("# OF REFILLS")>0
SET X1=PSOX("FILL DATE")
SET X2=$SELECT((PSOX("DAYS SUPPLY")-10\1)<1:1,1:PSOX("DAYS SUPPLY")-10\1)
DO C^%DTC
SET PSOX("NEXT POSSIBLE REFILL")=$PIECE(X,".")
KILL X
+12 SET PSOX("TYPE OF RX")=0
SET PSOX("DISPENSED DATE")=PSOX("FILL DATE")
DO NOW^%DTC
SET PSOX("LOGIN DATE")=$SELECT($PIECE($GET(OR0),"^",12):$PIECE($GET(OR0),"^",12),1:%)
KILL %,X
+13 SET PSOX("STATUS")=$SELECT($GET(PSOX("STATUS"))]"":PSOX("STATUS"),$DATA(PSORX("VERIFY")):1,$DATA(PSOX("NOPSDRPH")):1,1:0)
+14 SET PSOX("COPIES")=$SELECT($GET(PSOX("COPIES"))]"":PSOX("COPIES"),1:1)
+15 IF $GET(PSORX("PHARM"))]""
SET PSOX("PHARMACIST")=PSORX("PHARM")
KILL PSORX("PHARM")
INITX QUIT
+1 ;
NFILE IF $GET(OR0)
Begin DoDot:1
+1 DO NOOR^PSONEW
if $GET(PSONEW("DFLG"))
QUIT
+2 IF $GET(PSOSIGFL)!($GET(PSODRUG("OI"))'=$PIECE(OR0,"^",8))
SET PSONEW("CLERK CODE")=DUZ
SET PSONEW("REMARKS")=$GET(PSONEW("REMARKS"))_" CPRS Order #"_$PIECE(OR0,"^")_" Edited."
End DoDot:1
if $GET(PSONEW("DFLG"))
QUIT
+3 SET DIC="^PSRX("
SET DLAYGO=52
SET DIC(0)="L"
SET X=PSOX("RX #")
KILL DD,DO
DO FILE^DICN
SET PSOX("IRXN")=+Y
KILL DLAYGO,X,Y,DIC,DD,DO
+4 IF '$DATA(^XUSEC("PSORPH",DUZ))!($DATA(PSOX("NOPSDRPH")))
IF $$DS^PSSDSAPI&(+$GET(^TMP("PSODOSF",$JOB,0)))
SET PSON52(PSOX("IRXN"),"STA")=1
SET PSOX("STATUS")=1
+5 FOR PSOX1=0:1
SET PSON52=$PIECE($TEXT(DD+PSOX1),";;",2,4)
if PSON52=""
QUIT
KILL PSOY
SET PSOY=$PIECE(PSON52,";;")
IF $GET(@PSOY)]""
SET $PIECE(PSON52(PSOX("IRXN"),$PIECE(PSON52,";;",2)),"^",$PIECE(PSON52,";;",3))=@PSOY
+6 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
+7 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))
+8 IF $GET(PSOX("ODOSE",I))]""
SET ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
End DoDot:1
+9 SET ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
+10 ;*441-IND
+11 IF $GET(PSOX("IND"))]""
SET ^PSRX(PSOX("IRXN"),"IND")=PSOX("IND")_$SELECT($GET(PSOX("INDF")):"^"_PSOX("INDF"),1:"")
if $GET(PSOX("INDO"))]""
SET $PIECE(^PSRX(PSOX("IRXN"),"IND"),"^",3)=PSOX("INDO")
+12 KILL PSOX1,PSOY
+13 SET PSOX1=""
FOR
SET PSOX1=$ORDER(PSON52(PSOX("IRXN"),PSOX1))
if PSOX1=""
QUIT
SET ^PSRX(PSOX("IRXN"),PSOX1)=$GET(PSON52(PSOX("IRXN"),PSOX1))
+14 ; PSO*7*505 - quantity check - leading zeros
+15 NEW QTYTMP
+16 SET QTYTMP=$PIECE(^PSRX(PSOX("IRXN"),0),U,7)
+17 IF QTYTMP["."
Begin DoDot:1
+18 if $PIECE(QTYTMP,".")'=""
QUIT
+19 ;Q:$P(QTYTMP,".")=0
+20 SET $PIECE(^PSRX(PSOX("IRXN"),0),U,7)=0_QTYTMP
End DoDot:1
+21 ; PSO*7*505 - end quantity check - leading zeros
+22 IF $ORDER(PSOX("SIG",0))
Begin DoDot:1
+23 SET D=0
FOR
SET D=$ORDER(PSOX("SIG",D))
if 'D
QUIT
SET ^PSRX(PSOX("IRXN"),"INS1",D,0)=PSOX("SIG",D)
SET TP=$GET(TP)+1
+24 SET ^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^"_TP_"^"_TP_"^"_DT_"^^"
KILL TP,D
End DoDot:1
+25 IF $GET(PSOX("SINS"))]""
SET ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")
+26 IF $GET(SIGOK)
Begin DoDot:1
+27 SET $PIECE(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1
SET ^PSRX(PSOX("IRXN"),"SIG1",0)="^52.04A^^"
+28 SET D=0
FOR
SET D=$ORDER(SIG(D))
if 'D
QUIT
SET ^PSRX(PSOX("IRXN"),"SIG1",D,0)=SIG(D)
SET $PIECE(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)=+$PIECE(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)+1
SET $PIECE(^(0),"^",4)=+$PIECE(^(0),"^",4)+1
if '$ORDER(SIG(D))
QUIT
+29 KILL SIG
End DoDot:1
+30 IF $DATA(PSOINSFL)
SET ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^1^1"
SET ^PSRX(PSOX("IRXN"),"A",1,0)=DT_"^G^^0^Patient Instructions "_$SELECT(PSOINSFL=1:"",1:"Not ")_"Sent By Provider."
+31 ;PSO*441 - marked in CPRS
IF $GET(PSOTITRF)
Begin DoDot:1
+32 SET $PIECE(^PSRX(PSOX("IRXN"),"TIT"),"^",3)=1
SET COMM="MARKED as Titration"
+33 DO RXACT^PSOBPSU2(PSOX("IRXN"),,COMM,"K",PSONEW("CLERK CODE"))
End DoDot:1
+34 IF $GET(OR0)
Begin DoDot:1
+35 ; Allow CS from eRX to proceed without OR0|24 being set
+36 NEW ERXIEN,PSCSERX
SET ERXIEN=$$ERXIEN^PSOERXUT($GET(ORD)_"P")
SET PSCSERX=0
+37 IF ERXIEN
IF $$GET1^DIQ(52.49,ERXIEN,95.1,"I")
IF $$CS^PSOERXA0(+$$GET1^DIQ(52.49,ERXIEN,3.2,"I"))
SET PSCSERX=1
+38 ;Allow processing to continue if ERX order and is a CS without $P(OR0,"^",24)
+39 IF $PIECE(OR0,"^",24)!PSCSERX
SET $PIECE(^PSRX(PSOX("IRXN"),"PKI"),"^",1,3)=$SELECT($GET(PSOSIGFL):"^1^",1:"1^^")
DO ACLOG
+40 NEW ORDIEN
SET ORDIEN=$ORDER(^PS(52.41,"B",$PIECE(OR0,"^"),0))
+41 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
+42 SET $PIECE(^PSRX(PSOX("IRXN"),"PKI"),"^",1,3)="^^1"
End DoDot:2
End DoDot:1
+43 IF $PIECE($GET(PSOX("CS")),"^")
IF '+$PIECE($GET(^PSRX(PSOX("IRXN"),"PKI")),"^")
IF '+$PIECE($GET(^PSRX(PSOX("IRXN"),"PKI")),"^",3)
Begin DoDot:1
+44 SET $PIECE(^PSRX(PSOX("IRXN"),"PKI"),"^",2)=1
End DoDot:1
+45 KILL PSOX1,PSOFINFL,HLDSIG,D,PSOINSFL,D
+46 if $GET(^TMP("PSODAI",$JOB,0))
Begin DoDot:1
+47 SET $PIECE(^PSRX(PSOX("IRXN"),3),"^",6)=1
+48 IF $ORDER(^TMP("PSODAI",$JOB,0))
SET DAI=0
FOR
SET DAI=$ORDER(^TMP("PSODAI",$JOB,DAI))
if 'DAI
QUIT
Begin DoDot:2
+49 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)
+50 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
+51 KILL ^TMP("PSODAI",$JOB),DAI
End DoDot:1
+52 IF $GET(PSOX("CHCS NUMBER"))'=""
SET $PIECE(^PSRX(PSOX("IRXN"),"EXT"),"^")=$GET(PSOX("CHCS NUMBER"))
+53 IF $GET(PSOX("EXTERNAL SYSTEM"))'=""
SET $PIECE(^PSRX(PSOX("IRXN"),"EXT"),"^",2)=$GET(PSOX("EXTERNAL SYSTEM"))
+54 IF $GET(PSOX("NEWCOPAY"))
SET ^PSRX(PSOX("IRXN"),"IB")=$GET(PSOX("NEWCOPAY"))
+55 ;Next line, set SC question based on Copay status?
IBQ ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,1:1)
+1 NEW PSOSCFLD
SET PSOSCFLD=$SELECT(PSOSCP'="":$GET(PSOANSQ("SC")),1:"")_"^"_$GET(PSOANSQ("MST"))_"^"_$GET(PSOANSQ("VEH"))_"^"_$GET(PSOANSQ("RAD"))_"^"_$GET(PSOANSQ("PGW"))_"^"_$GET(PSOANSQ("HNC"))_"^"_$GET(PSOANSQ("CV"))_"^"_$GET(PSOANSQ("SHAD"))
+2 IF PSOSCP<50&($TRANSLATE(PSOSCFLD,"^")'="")&($PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)'=1)
Begin DoDot:1
+3 ;don't set if SC % is null or 0, just set it in ICD node
SET ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD
KILL PSOSCFLD
End DoDot:1
+4 DO ICD^PSODIAG
+5 if $$SWSTAT^IBBAPI()
DO GACT^PSOPFSU0(PSOX("IRXN"),0)
+6 if $GET(PSOTITRX)
DO SAVETIT(PSOTITRX,PSOX("IRXN"))
+7 KILL PSOTITRX,PSOANSQ,PSOANSQD,PSOX("NEWCOPAY")
+8 LOCK -^PSRX("B",PSOX("IRXN"))
+9 QUIT
+10 ;
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(PSONEW("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(PSONEW("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 PSOCSP("ISSUE DATE")'=PSONEW("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 PSOCSP("DAYS SUPPLY")'=PSONEW("DAYS SUPPLY")
SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DAYS SUPPLY: "_PSOCSP("DAYS SUPPLY")
+12 IF PSOCSP("QTY")'=PSONEW("QTY")
SET CNT=CNT+1
SET ^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^QTY: "_PSOCSP("QTY")
+13 IF PSOCSP("# OF REFILLS")'=PSONEW("# 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 ;
PS55 ;
+1 LOCK +^PS(55,PSODFN,"P"):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
+2 if '$DATA(^PS(55,PSODFN,"P",0))
SET ^(0)="^55.03PA^^"
+3 FOR PSOX1=$PIECE(^PS(55,PSODFN,"P",0),"^",3):1
if '$DATA(^PS(55,PSODFN,"P",PSOX1))
QUIT
+4 SET PSOX("55 IEN")=PSOX1
+5 SET ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN")
SET $PIECE(^PS(55,PSODFN,"P",0),"^",3,4)=PSOX1_"^"_($PIECE(^PS(55,PSODFN,"P",0),"^",4)+1)
+6 SET ^PS(55,PSODFN,"P","A",PSONEW("STOP DATE"),PSOX("IRXN"))=""
PS55X LOCK -^PS(55,PSODFN,"P")
+1 KILL PSOX1
+2 QUIT
DIK ;
+1 IF $DATA(^XUSEC("PSORPH",DUZ))
SET DA=PSOX("IRXN")
SET DIE=52
SET DR="41////"_PSOCOU_";S:'X Y=""@1"";42////"_PSOCOUU_";@1"
DO ^DIE
KILL DIE,DR
+2 ;p753
IF $DATA(^XUSEC("PSORPH",DUZ))
SET DA=PSOX("IRXN")
SET DIE=52
SET DR="100.2////"_PSOMAILX
DO ^DIE
KILL DIE,DR
+3 KILL DIK,DA
SET DIK="^PSRX("
SET DA=PSOX("IRXN")
DO IX1^DIK
KILL DIK
+4 SET DA=PSOX("IRXN")
DO ORC^PSORN52C
+5 QUIT
FINISH ;
ANQ IF $GET(ANQDATA)]""
DO NOW^%DTC
HANG 1
if $DATA(^PS(52.52,"B",%))
GOTO ANQ
Begin DoDot:1
+1 KILL DD,DO
SET DIC="^PS(52.52,"
SET DIC(0)="L"
SET DLAYGO=52.52
SET X=%
DO FILE^DICN
KILL DIC,DLAYGO,DD,DO
+2 SET ^PS(52.52,+Y,0)=$PIECE(Y,"^",2)_"^"_PSOX("IRXN")_"^"_ANQDATA
SET ^PS(52.52,"A",PSOX("IRXN"),+Y)=""
KILL X,Y,%,ANQREM
End DoDot:1
+3 ;PSO 457 Added H 1 to line tag ANQ
+4 ; ** START NCC REMEDIATION ** 457/RTW RJS
+5 ;ADD ADDITIONAL LOGIC FOR ORDERING PROVIDER RJS/457
IF $DATA(ANQDATA)
Begin DoDot:1
+6 IF $PIECE($GET(ANQDATA),"^",2)["UNKNOWN"
IF $DATA(PSOX("PROVIDER"))
SET $PIECE(ANQDATA,"^",2)=PSOX("PROVIDER")
+7 IF $DATA(PSOX("PROVIDER"))
IF $PIECE($GET(ANQDATA),"^",2)'=PSOX("PROVIDER")
SET $PIECE(ANQDATA,"^",2)=PSOX("PROVIDER")
End DoDot:1
+8 IF $GET(ANQDATA)]""
NEW PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK,DTM
DO NOW^%DTC
SET DTM=%
if $$FIND1^DIC(52.52,,"X",DTM)
GOTO ANQ
Begin DoDot:1
+9 SET PSOUSER=$PIECE(ANQDATA,"^",2)
SET PSO1PH=$PIECE(ANQDATA,"^")
SET PSO2PH=$PIECE(ANQDATA,"^",5)
+10 SET PSOREASN=$PIECE(ANQDATA,"^",3)
SET PSOREMRK=$PIECE(ANQDATA,"^",4)
+11 KILL DD,DO
SET DIC="^PS(52.52,"
SET DIC(0)="L"
SET DLAYGO=52.52
SET X=DTM
+12 DO FILE^DICN
KILL DIC,DLAYGO,DD,DO,DA,DR
+13 NEW PS52
SET (PS52,DA)=+Y
SET DIE="^PS(52.52,"
SET DR="1////^S X=PSOX(""IRXN"")"_";2////^S X=PSO1PH;3////^S X=PSOUSER;4////^S X=PSOREASN;5////^S X=PSOREMRK;6////^S X=PSO2PH"
+14 DO ^DIE
KILL DIE,DA,DR
+15 KILL X,Y,%,ANQREM
+16 DO ALERT^PSORENW0
End DoDot:1
+17 IF $$GET1^DIQ(50,+$GET(PSODRUG("IEN")),17.5)="PSOCLO1"
DO ^YSCLTST6
+18 ;/RBN END MODIFICATIONS FOR PSO*7.0*457
+19 ;
+20 NEW PSOTFIN
+21 IF $DATA(PSOX("NOPSDRPH"))!('$DATA(^XUSEC("PSORPH",DUZ)))
SET PSOTFIN=""
SET PSOTFIN=$$TECH2^PSODGDGP(PSOX("IRXN"),PSODFN,DUZ,.PSOX)
+22 IF $DATA(PSOX("NOPSDRPH"))!('$DATA(^XUSEC("PSORPH",DUZ)))
if $GET(PSOTFIN)=1
GOTO FINISHP
if $GET(PSOTFIN)=2
GOTO FINISHX
+23 ;
+24 IF PSOX("FILL DATE")>DT
IF $PIECE(PSOPAR,"^",6)
SET DA=PSOX("IRXN")
SET RXFL(PSOX("IRXN"))=0
DO SUS^PSORXL
KILL DA
GOTO FINISHX
+25 ;
+26 ; - Calling ECME for claims generation and transmission / REJECT handling
+27 NEW ACTION,PSOERX
+28 SET PSOERX=PSOX("IRXN")
+29 ;441 PAPI
IF ($GET(PSOX("MAIL/WINDOW"))'="P")
IF ($$SUBMIT^PSOBPSUT(PSOERX,0))
Begin DoDot:1
+30 SET ACTION=""
DO ECMESND^PSOBPSU1(PSOERX,0,"","OF")
+31 ; Quit if there is an unresolved Tricare/CHAMPVA non-billable reject code, PSO*7*358
+32 IF $$PSOET^PSOREJP3(PSOERX,0)
SET ACTION="Q"
QUIT
+33 IF $$FIND^PSOREJUT(PSOERX,0)
Begin DoDot:2
+34 SET ACTION=$$HDLG^PSOREJU1(PSOERX,0,"79,88,943","OF","IOQ","Q")
End DoDot:2
+35 IF $$STATUS^PSOBPSUT(PSOERX,0)="E PAYABLE"
Begin DoDot:2
+36 DO SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$GET(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,0))
End DoDot:2
End DoDot:1
IF ACTION="Q"!(ACTION="^")
QUIT
+37 ;
FINISHP ;
+1 IF $GET(PSORX("PSOL",1))']""
SET PSORX("PSOL",1)=PSOX("IRXN")_","
SET RXFL(PSOX("IRXN"))=0
GOTO FINISHX
+2 FOR PSOX1=0:0
SET PSOX1=$ORDER(PSORX("PSOL",PSOX1))
if 'PSOX1
QUIT
SET PSOX2=PSOX1
+3 IF $LENGTH(PSORX("PSOL",PSOX2))+$LENGTH(PSOX("IRXN"))<220
SET PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSOX("IRXN")_","
+4 IF '$TEST
SET PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
+5 SET RXFL(PSOX("IRXN"))=0
FINISHX ;call to build Rx array for bingo board
+1 IF $GET(PSORX("MAIL/WINDOW"))["W"
SET BINGCRT=1
SET BINGRTE="W"
SET BBFLG=1
DO BBRX^PSORN52C
+2 KILL PSOX1,PSOX2
+3 KILL ^TMP("PSODGI",$JOB),^TMP("PSOSER",$JOB),^TMP("PSOSERS",$JOB),^TMP("PSODGS",$JOB),^TMP("PSOTDD",$JOB),^TMP("PSODOSF",$JOB)
+4 QUIT
+5 ;
SAVETIT(TITRX,MNTRX) ; Save Titration/Maintenance dose Rx information
+1 IF '$DATA(^PSRX(+$GET(TITRX),0))!'$DATA(^PSRX(+$GET(MNTRX),0))
QUIT
+2 SET $PIECE(^PSRX(TITRX,"TIT"),"^",2,3)=MNTRX_"^1"
+3 DO RXACT^PSOBPSU2(TITRX,0,"Maintenance Rx#: "_$$GET1^DIQ(52,MNTRX,.01),"E")
+4 SET $PIECE(^PSRX(MNTRX,"TIT"),"^",1)=TITRX
+5 DO RXACT^PSOBPSU2(MNTRX,0,"Titration Rx#: "_$$GET1^DIQ(52,TITRX,.01),"E")
+6 QUIT
+7 ;
EOJ ;
+1 ;B xref locked in routine PSONRXN
+2 LOCK -^PSRX("B",PSOX("IRXN"))
KILL OTHDOS,DA,PSON52,PSOPRC,RTE,SCH,PSOX("INS"),PSONEW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT
+3 DO PSOUL^PSSLOCK(PSOX("IRXN"))
+4 QUIT
+5 ;
+6 ;;PSOX("SIG");;SIG;;1
DD ;;PSOX("RX #");;0;;1
+1 ;;PSOX("ISSUE DATE");;0;;13
+2 ;;PSODFN;;0;;2
+3 ;;PSOX("PATIENT STATUS");;0;;3
+4 ;;PSOX("PROVIDER");;0;;4
+5 ;;PSOX("CLINIC");;0;;5
+6 ;;PSODRUG("IEN");;0;;6
+7 ;;PSODRUG("TRADE NAME");;TN;;1
+8 ;;PSOX("QTY");;0;;7
+9 ;;PSOX("DAYS SUPPLY");;0;;8
+10 ;;PSOX("# OF REFILLS");;0;;9
+11 ;;PSOX("COPIES");;0;;18
+12 ;;PSOX("MAIL/WINDOW");;0;;11
+13 ;;PSOX("REMARKS");;3;;7
+14 ;;PSOX("ADMINCLINIC");;0;;15
+15 ;;PSOX("CLERK CODE");;0;;16
+16 ;;PSODRUG("COST");;0;;17
+17 ;;PSOSITE;;2;;9
+18 ;;PSOX("LOGIN DATE");;2;;1
+19 ;;PSOX("FILL DATE");;2;;2
+20 ;;PSOX("PHARMACIST");;2;;3
+21 ;;PSOX("LOT #");;2;;4
+22 ;;PSOX("DISPENSED DATE");;2;;5
+23 ;;PSOX("STOP DATE");;2;;6
+24 ;;PSODRUG("NDC");;2;;7
+25 ;;PSODRUG("DAW");;EPH;;1
+26 ;;PSODRUG("MANUFACTURER");;2;;8
+27 ;;PSOX("EXPIRATION DATE");;2;;11
+28 ;;PSOX("GENERIC PROVIDER");;2;;12
+29 ;;PSOX("RELEASED DATE/TIME");;2;;13
+30 ;;PSOX("METHOD OF PICK-UP");;MP;;1
+31 ;;PSOX("STATUS");;STA;;1
+32 ;;PSOX("LAST DISPENSED DATE");;3;;1
+33 ;;PSOX("NEXT POSSIBLE REFILL");;3;;2
+34 ;;PSOX("COSIGNING PROVIDER");;3;;3
+35 ;;PSOX("TYPE OF RX");;TYPE;;1
+36 ;;PSOX("SAND");;SAND;;1
+37 ;;PSOX("POE");;POE;;1
+38 ;;PSOX("INS");;INS;;1
+39 ;;PSOX("IND");;IND;;1
+40 ;;PSOX("INDF");;IND;;2
+41 ;;PSOX("INDO");;IND;;3
+42 ;;PSOX("MAIL EXEMPTION");;7;;2
