- 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 Jan 18, 2025@03:32:26 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