- PSORX1 ;BIR/SAB-medication processing driver ;06-Aug-2012 08:59;PLS
- ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,1004,182,195,233,268,300,170,320,326,1015**;DEC 1997;Build 62
- ;External reference ^PS(55 supported by DBIA 2228
- ;External reference ^DIC(31 supported by DBIA 658
- ;External reference ^DPT(D0,.372 supported by DBIA 1476
- ;External reference DISPPRF^DGPFAPI supported by DBIA #4563
- ;External reference ^ORRDI1 is supported by DBIA 4659
- ;External reference ^XTMP("ORRDI" is supported by DBIA 4660
- ;External reference ^PSUHL supported by DBIA 4803
- ;
- ;PSO*195 add call to display Patient Record Flag (DISPPRF^DGPFAPI)
- ; Modified - IHS/CIA/PLS - 12/10/03 - Line PT+3
- ; 10/06/05 - Moved VueCentric context change to APSPFUNC
- ; - IHS/MSC/PLS - Line OERR+4
- ; - IHS/MSC/PB - 05/29/2012 - Line OERR+30
- ; - IHS/MSC/PLS - 08/06/2012 - Line ELIG+1,RXSTA+5
- START K PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG S (PSOBCK,PSOERR)=1 D INIT G:PSORX("QFLG") END
- D PT G:$G(PSORX("QFLG")) END D FULL^VALM1 I $G(NOPROC) K NOPROC G NX
- ;call to add bingo board data to file 52.11
- F SLPPL=0:0 S SLPPL=$O(RXRS(SLPPL)) Q:'SLPPL D
- .I $P($G(^PSRX(SLPPL,"STA")),"^")'=5 K RXRS(SLPPL) Q
- .S RXREC=SLPPL D WIND^PSOSUPOE I $G(PBINGRTE) D BBADD^PSOSUPOE S (BINGCRT,BINGRTE)=1 S:$G(PSOFROM)'="NEW" PSOFROM="REFILL"
- K TM,TM1 I $G(PSORX("PSOL",1))]""!($D(RXRS)) D ^PSORXL K PSORX
- G:$G(NOBG) NX
- S TM=$P(^TMP("PSOBB",$J),"^"),TM1=$P(^TMP("PSOBB",$J),"^",2) K ^TMP("PSOBB",$J)
- I $G(PSOFROM)="NEW"!($G(PSOFROM)="REFILL")!($G(PSOFROM)="PARTIAL") D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,BBRX,BBFLG
- NX I $G(POERR("DEAD"))!$G(PSOQFLG) D EOJ G START
- D EOJ G START
- END Q
- ;---------------------------------------------------------
- INIT ;
- S PSORX("QFLG")=0
- D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) S PSORX("QFLG")=1
- I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
- INITX Q
- ;
- PT ;
- K ^TMP("PSORXDC",$J),CLOZPAT,DIC,PSODFN,PSOPTLK S PSORX("QFLG")=0,DIC(0)="QEAM" D EN^PSOPATLK S Y=PSOPTLK
- I +Y'>0 S PSORX("QFLG")=1 G PTX
- ; IHS/CIA/PLS 12-10-03 - Fire VueCentric Patient Context change event.
- ;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
- ;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+Y)
- D SETPTCX^APSPFUNC(+Y)
- OERR N:$G(MEDP) PAT,POERR K PSOXFLG S (DFN,PSODFN)=+Y,PSORX("NAME")=$P(Y,"^",2)
- K NPPROC,PSOQFLG,DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=.351,DIQ="PSOPTPST" D EN^DIQ1 K DIC,DA,DR,DIQ D DEAD^PSOPTPST I $G(PSOQFLG) S NOPROC=1 Q
- ;PSO*195 move SSN write to here and add DISPPRF call
- S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")
- ;IHS/MSC/PLS - 10/13/10 - Changed from SSN to HRN
- ;W " ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
- W " ("_$$HRN^AUPNPAT(PSODFN,DUZ(2))_")"
- S PSONOAL="" D ALLERGY^PSOORUT2 D I PSONOAL'="" D PAUSE
- .I PSONOAL'="" W !,$C(7)," No Allergy Assessment!"
- D REMOTE
- N PSOUPDT
- S PSOUPDT=1
- I $G(XQY0)["PSO LMOE FINISH" S PSOUPDT=0
- D CHKADDR^PSOBAI(PSODFN,1,PSOUPDT)
- D:(XQY0["PSO LMOE FINISH")&('$G(SNGLPAT)) DISPPRF^DGPFAPI(PSODFN)
- ;
- I $P($G(^PS(55,PSODFN,"LAN")),"^") W !?10,"Patient has another language preference!",! H 3
- I $G(^PS(55,"ASTALK",PSODFN)) W !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",! H 2 D MAIL
- D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
- ;Call to display remote/local prescriptions
- I '$G(PSOFIN) D RDICHK^PSORMRX(PSODFN)
- S PSOQFLG=0,DIC="^PS(55,",DLAYGO=55
- I '$D(^PS(55,PSODFN,0)) D
- .K DD,DO S DIC(0)="L",(DINUM,X)=PSODFN D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO
- ..S $P(^PS(55,PSODFN,0),"^")=PSODFN K DIK S DA=PSODFN,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
- D RXSTA
- S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
- I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ
- .L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Patient Data is Being Edited by Another User!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1 Q
- .S PSOXFLG=1,SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")",! K SSN
- .;IHS/MSC/PB - 03/30/2012 - Removed Other Language field
- .;S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
- .S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
- S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
- I $G(^PS(55,PSODFN,"PS"))']"" D I $G(POERR("QFLG")) G EOJ
- .W !!,"Patient Status Required!!",! D ELIG
- .W ! K POERR("QFLG"),DIC,DR,DIE S DIC("A")="RX PATIENT STATUS: ",DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
- .I $D(DIRUT)!(Y=-1) D Q
- ..W $C(7),"Required Data!",! S POERR("QFLG")=1 S:$G(PSOFIN) PSOQUIT=1
- ..I $O(^PS(55,PSODFN,0))="" S DA=PSODFN,DIK="^PS(55," D ^DIK
- .S ^PS(55,PSODFN,"PS")=+Y,PSORX("PATIENT STATUS")=$P(^PS(53,+Y,0),"^")
- .K DIRUT,DTOUT,DUOUT,X,Y,DA
- Q:$G(PSOFIN)
- D ^PSOBUILD
- F PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY" S RTN=PT_"^PSOPTPST" D @RTN Q:$G(POERR("DEAD"))!($G(PSOQFLG))
- I $G(POERR("DEAD")) S POERR("QFLG")=1 F II=0:0 S II=$O(^PS(52.41,"P",PSODFN,II)) D:$P($G(^PS(52.41,II,0)),"^",3)'="DC"&($P($G(^(0)),"^",3)'="DE") DC^PSOORFI2
- K PSOERR("DEAD"),II I $G(PSOQFLG) S POERR("QFLG")=1 G EOJ Q
- S (PAT,PSOXXDFN)=PSODFN,POERR=1 D ^PSOORUT2,BLD^PSOORUT1,EN^PSOLMUTL
- D CLEAR^VALM1 G:$G(PSOQUIT) PTX D EN^PSOLMAO
- S (DFN,PSODFN)=PSOXXDFN K DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED
- I $O(RXFL("")),$P(^PS(55,PSODFN,0),"^",7)="" D
- . N %
- . D NOW^%DTC
- . S $P(^PS(55,PSODFN,0),"^",7)=$E(%,1,12),$P(^(0),"^",8)="A" D LOGDFN^PSUHL(PSODFN)
- PTX ;
- K X,Y,^TMP("PS",$J),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR,PSOPATLK
- Q
- EOJ ;
- K PSOERR,PSOMED,PSORX,PSOSD,PSODRUG,PSODFN,PSOOPT,PSOBILL,PSOIBQS,PSOCPAY,PSOPF,PSOPI,COMM,DGI,DGS,PT,PTDY,PTRF,RN,RTN,SERS,ST0,STAT,DFN,STOP,SLPPL,RXREC
- K:'$G(MEDP) PSOQFLG
- D KVA^VADPT,FULL^VALM1 K PSOLST,PSOXFLG,PSCNT,PSDIS,PSOAL,P1,LOG,%,%DT,%I,D0,DAT,DFN,DRG,ORX,PSON,PSOPTPST,PSORX,PTST,PSOBCK,PSOID,PSOBXPUL
- K INCOM,SIG,SG,STP,RX0,RXN,RX2,RX3,RTS,C,DEAD,PS,PSOCLC,PSOCNT,PSOCT,PSODA,PSOFROM,PSOHD,R3,REA,RF,RFD,RFM,RLD,RXNUM,RXP,RXPR,RXRP,RXRS,STR,POERR,VALMSG
- K ^TMP("PSORXDC",$J),^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J) I '$G(MEDP),'$G(PSOQUIT) K PAT
- K PSORX,RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG
- Q
- ELIG ; shows eligibility and disabilities
- ;IHS/MSC/PLS - 08/6/2012
- ;D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2)
- W !,"Eligibility: "_$$GET1^DIQ(9000001,DFN,1112)
- W !,"Disabilities: " F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
- .S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
- .W:$L(PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 !,?15
- .W $S($G(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
- K N
- Q
- PROFILE ;
- S (PSORX("REFILL"),PSORX("RENEW"))=0,PSOX="" D ^PSOBUILD
- I '$G(PSOSD) W !,"This patient has no prescriptions" S:'$D(DFN) DFN=PSODFN D GMRA^PSODEM G PROFILEX
- S (PSODRG,PSOX)="" F S PSODRG=$O(PSOSD(PSODRG)) Q:PSODRG="" F S PSOX=$O(PSOSD(PSODRG,PSOX)) Q:PSOX="" S:$P(PSOSD(PSODRG,PSOX),"^",3)="" PSORX("RENEW")=1 S:$P(PSOSD(PSODRG,PSOX),"^",4)="" PSORX("REFILL")=1
- K PSOX
- PROFILEX Q
- ;
- MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
- I $P($G(^PS(59,PSOSITE,"STALK")),"^")="" Q ; NO SCRIPTALK PRINTER SET UP FOR THIS DIVISION
- N MAIL
- S MAIL=$G(^PS(55,PSODFN,0)) I $P(MAIL,"^",3)>1 Q
- MAILP W !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail"
- W !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
- R !,"MAIL: ",MAIL:120
- I MAIL?1"^".E Q
- I MAIL<2!(MAIL>4) W !,"INVALID MAIL SETTING - ENTER 2,3, OR 4" G MAILP
- W " ",$S(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
- S $P(^PS(55,PSODFN,0),"^",3)=MAIL
- Q
- REMOTE ;
- I $T(HAVEHDR^ORRDI1)']"" Q
- I '$$HAVEHDR^ORRDI1 Q
- I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) W !,"Remote data not available - Only local order checks processed." D Q
- .K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W ! K DIR
- Q
- PAUSE ;
- W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
- Q
- ;
- RXSTA ; DISPLAY ELIGIBILITY & PROMPT FOR RX PATIENT STATUS
- N DA,PSOSTA
- I '$G(PSODFN) Q
- S DA=PSODFN,PSOSTA=$G(^PS(55,PSODFN,"PS"))
- I XQY0["PSO LMOE FINISH"!(XQY0["PSO LM BACKDOOR ORDERS") I PSOSTA]"" D
- .;IHS/MSC/PLS - 08/06/2012
- .;D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"")
- .W !,"Eligibility: "_$$GET1^DIQ(9000001,DFN,1112)
- .S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2)
- .S DIC("A")="RX PATIENT STATUS: ",DIC("B")=PSOSTA,DIC(0)="QEAMZ",DIC=53 D ^DIC K DIC
- .I +Y>0,+Y'=PSOSTA S DIE="^PS(55,",DR="3////"_+Y D ^DIE
- Q
- PSORX1 ;BIR/SAB-medication processing driver ;06-Aug-2012 08:59;PLS
- +1 ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,1004,182,195,233,268,300,170,320,326,1015**;DEC 1997;Build 62
- +2 ;External reference ^PS(55 supported by DBIA 2228
- +3 ;External reference ^DIC(31 supported by DBIA 658
- +4 ;External reference ^DPT(D0,.372 supported by DBIA 1476
- +5 ;External reference DISPPRF^DGPFAPI supported by DBIA #4563
- +6 ;External reference ^ORRDI1 is supported by DBIA 4659
- +7 ;External reference ^XTMP("ORRDI" is supported by DBIA 4660
- +8 ;External reference ^PSUHL supported by DBIA 4803
- +9 ;
- +10 ;PSO*195 add call to display Patient Record Flag (DISPPRF^DGPFAPI)
- +11 ; Modified - IHS/CIA/PLS - 12/10/03 - Line PT+3
- +12 ; 10/06/05 - Moved VueCentric context change to APSPFUNC
- +13 ; - IHS/MSC/PLS - Line OERR+4
- +14 ; - IHS/MSC/PB - 05/29/2012 - Line OERR+30
- +15 ; - IHS/MSC/PLS - 08/06/2012 - Line ELIG+1,RXSTA+5
- START KILL PSOQFLG,PSOID,PSOFIN,PSOQUIT,PSODRUG
- SET (PSOBCK,PSOERR)=1
- DO INIT
- IF PSORX("QFLG")
- GOTO END
- +1 DO PT
- IF $GET(PSORX("QFLG"))
- GOTO END
- DO FULL^VALM1
- IF $GET(NOPROC)
- KILL NOPROC
- GOTO NX
- +2 ;call to add bingo board data to file 52.11
- +3 FOR SLPPL=0:0
- SET SLPPL=$ORDER(RXRS(SLPPL))
- IF 'SLPPL
- QUIT
- Begin DoDot:1
- +4 IF $PIECE($GET(^PSRX(SLPPL,"STA")),"^")'=5
- KILL RXRS(SLPPL)
- QUIT
- +5 SET RXREC=SLPPL
- DO WIND^PSOSUPOE
- IF $GET(PBINGRTE)
- DO BBADD^PSOSUPOE
- SET (BINGCRT,BINGRTE)=1
- IF $GET(PSOFROM)'="NEW"
- SET PSOFROM="REFILL"
- End DoDot:1
- +6 KILL TM,TM1
- IF $GET(PSORX("PSOL",1))]""!($DATA(RXRS))
- DO ^PSORXL
- KILL PSORX
- +7 IF $GET(NOBG)
- GOTO NX
- +8 SET TM=$PIECE(^TMP("PSOBB",$JOB),"^")
- SET TM1=$PIECE(^TMP("PSOBB",$JOB),"^",2)
- KILL ^TMP("PSOBB",$JOB)
- +9 IF $GET(PSOFROM)="NEW"!($GET(PSOFROM)="REFILL")!($GET(PSOFROM)="PARTIAL")
- IF $DATA(BINGCRT)&($DATA(BINGRTE)&($DATA(DISGROUP)))
- DO ^PSOBING1
- KILL BINGCRT,BINGRTE,BBRX,BBFLG
- NX IF $GET(POERR("DEAD"))!$GET(PSOQFLG)
- DO EOJ
- GOTO START
- +1 DO EOJ
- GOTO START
- END QUIT
- +1 ;---------------------------------------------------------
- INIT ;
- +1 SET PSORX("QFLG")=0
- +2 IF '$DATA(PSOPAR)
- DO ^PSOLSET
- IF '$DATA(PSOPAR)
- SET PSORX("QFLG")=1
- +3 IF $PIECE($GET(PSOPAR),"^",2)
- IF '$DATA(^XUSEC("PSORPH",DUZ))
- SET PSORX("VERIFY")=1
- INITX QUIT
- +1 ;
- PT ;
- +1 KILL ^TMP("PSORXDC",$JOB),CLOZPAT,DIC,PSODFN,PSOPTLK
- SET PSORX("QFLG")=0
- SET DIC(0)="QEAM"
- DO EN^PSOPATLK
- SET Y=PSOPTLK
- +2 IF +Y'>0
- SET PSORX("QFLG")=1
- GOTO PTX
- +3 ; IHS/CIA/PLS 12-10-03 - Fire VueCentric Patient Context change event.
- +4 ;IHS/CIA/PLS - 10/06/2005 Moved EHR context change call to APSPFUNC
- +5 ;S X="CIAVCXPT" X ^%ZOSF("TEST") I $T D SETCTX^CIAVCXPT(+Y)
- +6 DO SETPTCX^APSPFUNC(+Y)
- OERR IF $GET(MEDP)
- NEW PAT,POERR
- KILL PSOXFLG
- SET (DFN,PSODFN)=+Y
- SET PSORX("NAME")=$PIECE(Y,"^",2)
- +1 KILL NPPROC,PSOQFLG,DIC,DR,DIQ
- SET DIC=2
- SET DA=PSODFN
- SET DR=.351
- SET DIQ="PSOPTPST"
- DO EN^DIQ1
- KILL DIC,DA,DR,DIQ
- DO DEAD^PSOPTPST
- IF $GET(PSOQFLG)
- SET NOPROC=1
- QUIT
- +2 ;PSO*195 move SSN write to here and add DISPPRF call
- +3 SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
- WRITE !!?10,$CHAR(7),PSORX("NAME")
- +4 ;IHS/MSC/PLS - 10/13/10 - Changed from SSN to HRN
- +5 ;W " ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
- +6 WRITE " ("_$$HRN^AUPNPAT(PSODFN,DUZ(2))_")"
- +7 SET PSONOAL=""
- DO ALLERGY^PSOORUT2
- Begin DoDot:1
- +8 IF PSONOAL'=""
- WRITE !,$CHAR(7)," No Allergy Assessment!"
- End DoDot:1
- IF PSONOAL'=""
- DO PAUSE
- +9 DO REMOTE
- +10 NEW PSOUPDT
- +11 SET PSOUPDT=1
- +12 IF $GET(XQY0)["PSO LMOE FINISH"
- SET PSOUPDT=0
- +13 DO CHKADDR^PSOBAI(PSODFN,1,PSOUPDT)
- +14 IF (XQY0["PSO LMOE FINISH")&('$GET(SNGLPAT))
- DO DISPPRF^DGPFAPI(PSODFN)
- +15 ;
- +16 IF $PIECE($GET(^PS(55,PSODFN,"LAN")),"^")
- WRITE !?10,"Patient has another language preference!",!
- HANG 3
- +17 IF $GET(^PS(55,"ASTALK",PSODFN))
- WRITE !,"Patient is enrolled to receive ScripTalk 'talking' prescription labels.",!
- HANG 2
- DO MAIL
- +18 DO NOW^%DTC
- SET TM=$EXTRACT(%,1,12)
- SET TM1=$PIECE(TM,".",2)
- SET ^TMP("PSOBB",$JOB)=TM_"^"_TM1
- +19 ;Call to display remote/local prescriptions
- +20 IF '$GET(PSOFIN)
- DO RDICHK^PSORMRX(PSODFN)
- +21 SET PSOQFLG=0
- SET DIC="^PS(55,"
- SET DLAYGO=55
- +22 IF '$DATA(^PS(55,PSODFN,0))
- Begin DoDot:1
- +23 KILL DD,DO
- SET DIC(0)="L"
- SET (DINUM,X)=PSODFN
- DO FILE^DICN
- IF Y<1
- Begin DoDot:2
- +24 SET $PIECE(^PS(55,PSODFN,0),"^")=PSODFN
- KILL DIK
- SET DA=PSODFN
- SET DIK="^PS(55,"
- SET DIK(1)=.01
- DO EN^DIK
- KILL DIK
- End DoDot:2
- KILL DIC,DA,DR,DD,DO
- End DoDot:1
- +25 DO RXSTA
- +26 SET PSOLOUD=1
- IF $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
- DO EN^PSOHLUP(PSODFN)
- KILL PSOLOUD
- +27 IF $GET(^PS(55,PSODFN,"PS"))']""
- Begin DoDot:1
- +28 LOCK +^PS(55,PSODFN):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
- IF '$TEST
- WRITE $CHAR(7),!!,"Patient Data is Being Edited by Another User!",!
- SET POERR("QFLG")=1
- IF $GET(PSOFIN)
- SET PSOQUIT=1
- QUIT
- +29 SET PSOXFLG=1
- SET SSN=$PIECE(^DPT(PSODFN,0),"^",9)
- WRITE !!?10,$CHAR(7),PSORX("NAME")_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_")",!
- KILL SSN
- +30 ;IHS/MSC/PB - 03/30/2012 - Removed Other Language field
- +31 ;S DIE=55,DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106;106.1",DA=PSODFN W !!,?5,">>PHARMACY PATIENT DATA<<",! D ^DIE L -^PS(55,PSODFN)
- +32 SET DIE=55
- SET DR=".02;.03;.04;.05;1;D ELIG^PSORX1;3;50;106.1"
- SET DA=PSODFN
- WRITE !!,?5,">>PHARMACY PATIENT DATA<<",!
- DO ^DIE
- LOCK -^PS(55,PSODFN)
- End DoDot:1
- IF $GET(POERR("QFLG"))
- GOTO EOJ
- +33 SET PSOX=$GET(^PS(55,PSODFN,"PS"))
- IF PSOX]""
- SET PSORX("PATIENT STATUS")=$PIECE($GET(^PS(53,PSOX,0)),"^")
- +34 IF $GET(^PS(55,PSODFN,"PS"))']""
- Begin DoDot:1
- +35 WRITE !!,"Patient Status Required!!",!
- DO ELIG
- +36 WRITE !
- KILL POERR("QFLG"),DIC,DR,DIE
- SET DIC("A")="RX PATIENT STATUS: "
- SET DIC(0)="QEAMZ"
- SET DIC=53
- DO ^DIC
- KILL DIC
- +37 IF $DATA(DIRUT)!(Y=-1)
- Begin DoDot:2
- +38 WRITE $CHAR(7),"Required Data!",!
- SET POERR("QFLG")=1
- IF $GET(PSOFIN)
- SET PSOQUIT=1
- +39 IF $ORDER(^PS(55,PSODFN,0))=""
- SET DA=PSODFN
- SET DIK="^PS(55,"
- DO ^DIK
- End DoDot:2
- QUIT
- +40 SET ^PS(55,PSODFN,"PS")=+Y
- SET PSORX("PATIENT STATUS")=$PIECE(^PS(53,+Y,0),"^")
- +41 KILL DIRUT,DTOUT,DUOUT,X,Y,DA
- End DoDot:1
- IF $GET(POERR("QFLG"))
- GOTO EOJ
- +42 IF $GET(PSOFIN)
- QUIT
- +43 DO ^PSOBUILD
- +44 FOR PT="GET","DEAD","INP","CNH","TPB","ADDRESS","COPAY"
- SET RTN=PT_"^PSOPTPST"
- DO @RTN
- IF $GET(POERR("DEAD"))!($GET(PSOQFLG))
- QUIT
- +45 IF $GET(POERR("DEAD"))
- SET POERR("QFLG")=1
- FOR II=0:0
- SET II=$ORDER(^PS(52.41,"P",PSODFN,II))
- IF $PIECE($GET(^PS(52.41,II,0)),"^",3)'="DC"&($PIECE($GET(^(0)),"^",3)'="DE")
- DO DC^PSOORFI2
- +46 KILL PSOERR("DEAD"),II
- IF $GET(PSOQFLG)
- SET POERR("QFLG")=1
- GOTO EOJ
- QUIT
- +47 SET (PAT,PSOXXDFN)=PSODFN
- SET POERR=1
- DO ^PSOORUT2
- DO BLD^PSOORUT1
- DO EN^PSOLMUTL
- +48 DO CLEAR^VALM1
- IF $GET(PSOQUIT)
- GOTO PTX
- DO EN^PSOLMAO
- +49 SET (DFN,PSODFN)=PSOXXDFN
- KILL DIE,DIC,DLAYGO,DR,DA,PSOX,PSORXED
- +50 IF $ORDER(RXFL(""))
- IF $PIECE(^PS(55,PSODFN,0),"^",7)=""
- Begin DoDot:1
- +51 NEW %
- +52 DO NOW^%DTC
- +53 SET $PIECE(^PS(55,PSODFN,0),"^",7)=$EXTRACT(%,1,12)
- SET $PIECE(^(0),"^",8)="A"
- DO LOGDFN^PSUHL(PSODFN)
- End DoDot:1
- PTX ;
- +1 KILL X,Y,^TMP("PS",$JOB),C,DEA,PRC,PSCNT,PSOACT,PSOCLC,PSOCS,PSOCT,PSOFINFL,PSOHD,PSOLST,PSOOPT,PSOPF,PSOX,PSOX1,PSOXXDFN,SIGOK,STP,STR,PSOPATLK
- +2 QUIT
- EOJ ;
- +1 KILL PSOERR,PSOMED,PSORX,PSOSD,PSODRUG,PSODFN,PSOOPT,PSOBILL,PSOIBQS,PSOCPAY,PSOPF,PSOPI,COMM,DGI,DGS,PT,PTDY,PTRF,RN,RTN,SERS,ST0,STAT,DFN,STOP,SLPPL,RXREC
- +2 IF '$GET(MEDP)
- KILL PSOQFLG
- +3 DO KVA^VADPT
- DO FULL^VALM1
- KILL PSOLST,PSOXFLG,PSCNT,PSDIS,PSOAL,P1,LOG,%,%DT,%I,D0,DAT,DFN,DRG,ORX,PSON,PSOPTPST,PSORX,PTST,PSOBCK,PSOID,PSOBXPUL
- +4 KILL INCOM,SIG,SG,STP,RX0,RXN,RX2,RX3,RTS,C,DEAD,PS,PSOCLC,PSOCNT,PSOCT,PSODA,PSOFROM,PSOHD,R3,REA,RF,RFD,RFM,RLD,RXNUM,RXP,RXPR,RXRP,RXRS,STR,POERR,VALMSG
- +5 KILL ^TMP("PSORXDC",$JOB),^TMP("PSOAL",$JOB),^TMP("PSOAO",$JOB),^TMP("PSOSF",$JOB),^TMP("PSOPF",$JOB),^TMP("PSOPI",$JOB),^TMP("PSOPO",$JOB),^TMP("PSOHDR",$JOB)
- IF '$GET(MEDP)
- IF '$GET(PSOQUIT)
- KILL PAT
- +6 KILL PSORX,RFN,PSOXXDFN,VALM,VALMKEY,PSOBCK,SPOERR,PSOFLAG,VALMBCK,D,GMRA,GMRAL,GMRAREC,PSOSTA,PSODT,RXFL,NOBG,BBRX,BBFLG
- +7 QUIT
- ELIG ; shows eligibility and disabilities
- +1 ;IHS/MSC/PLS - 08/6/2012
- +2 ;D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"") S N=0 F S N=$O(VAEL(1,N)) Q:'N W !,?10,$P(VAEL(1,N),"^",2)
- +3 WRITE !,"Eligibility: "_$$GET1^DIQ(9000001,DFN,1112)
- +4 WRITE !,"Disabilities: "
- FOR I=0:0
- SET I=$ORDER(^DPT(DFN,.372,I))
- IF 'I
- QUIT
- SET I1=$SELECT($DATA(^DPT(DFN,.372,I,0)):^(0),1:"")
- IF +I1
- Begin DoDot:1
- +5 SET PSDIS=$SELECT($PIECE($GET(^DIC(31,+I1,0)),"^")]""&($PIECE($GET(^(0)),"^",4)']""):$PIECE(^(0),"^"),$PIECE($GET(^DIC(31,+I1,0)),"^",4)]"":$PIECE(^(0),"^",4),1:"")
- SET PSCNT=$PIECE(I1,"^",2)
- +6 IF $LENGTH(PSDIS_"-"_PSCNT_"% ("_$SELECT($PIECE(I1,"^",3)
- WRITE !,?15
- +7 WRITE $SELECT($GET(PSDIS)]"":PSDIS_"-",1:"")_PSCNT_"% ("_$SELECT($PIECE(I1,"^",3):"SC",1:"NSC")_"), "
- End DoDot:1
- +8 KILL N
- +9 QUIT
- PROFILE ;
- +1 SET (PSORX("REFILL"),PSORX("RENEW"))=0
- SET PSOX=""
- DO ^PSOBUILD
- +2 IF '$GET(PSOSD)
- WRITE !,"This patient has no prescriptions"
- IF '$DATA(DFN)
- SET DFN=PSODFN
- DO GMRA^PSODEM
- GOTO PROFILEX
- +3 SET (PSODRG,PSOX)=""
- FOR
- SET PSODRG=$ORDER(PSOSD(PSODRG))
- IF PSODRG=""
- QUIT
- FOR
- SET PSOX=$ORDER(PSOSD(PSODRG,PSOX))
- IF PSOX=""
- QUIT
- IF $PIECE(PSOSD(PSODRG,PSOX),"^",3)=""
- SET PSORX("RENEW")=1
- IF $PIECE(PSOSD(PSODRG,PSOX),"^",4)=""
- SET PSORX("REFILL")=1
- +4 KILL PSOX
- PROFILEX QUIT
- +1 ;
- MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
- +1 ; NO SCRIPTALK PRINTER SET UP FOR THIS DIVISION
- IF $PIECE($GET(^PS(59,PSOSITE,"STALK")),"^")=""
- QUIT
- +2 NEW MAIL
- +3 SET MAIL=$GET(^PS(55,PSODFN,0))
- IF $PIECE(MAIL,"^",3)>1
- QUIT
- MAILP WRITE !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail"
- +1 WRITE !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
- +2 READ !,"MAIL: ",MAIL:120
- +3 IF MAIL?1"^".E
- QUIT
- +4 IF MAIL<2!(MAIL>4)
- WRITE !,"INVALID MAIL SETTING - ENTER 2,3, OR 4"
- GOTO MAILP
- +5 WRITE " ",$SELECT(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
- +6 SET $PIECE(^PS(55,PSODFN,0),"^",3)=MAIL
- +7 QUIT
- REMOTE ;
- +1 IF $TEXT(HAVEHDR^ORRDI1)']""
- QUIT
- +2 IF '$$HAVEHDR^ORRDI1
- QUIT
- +3 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
- WRITE !,"Remote data not available - Only local order checks processed."
- Begin DoDot:1
- +4 KILL DIR
- WRITE !
- SET DIR(0)="EA"
- SET DIR("A")="Press Return to continue..."
- DO ^DIR
- WRITE !
- KILL DIR
- End DoDot:1
- QUIT
- +5 QUIT
- PAUSE ;
- +1 WRITE !
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- KILL DIR
- +2 QUIT
- +3 ;
- RXSTA ; DISPLAY ELIGIBILITY & PROMPT FOR RX PATIENT STATUS
- +1 NEW DA,PSOSTA
- +2 IF '$GET(PSODFN)
- QUIT
- +3 SET DA=PSODFN
- SET PSOSTA=$GET(^PS(55,PSODFN,"PS"))
- +4 IF XQY0["PSO LMOE FINISH"!(XQY0["PSO LM BACKDOOR ORDERS")
- IF PSOSTA]""
- Begin DoDot:1
- +5 ;IHS/MSC/PLS - 08/06/2012
- +6 ;D ELIG^VADPT W !,"Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:"")
- +7 WRITE !,"Eligibility: "_$$GET1^DIQ(9000001,DFN,1112)
- +8 SET N=0
- FOR
- SET N=$ORDER(VAEL(1,N))
- IF 'N
- QUIT
- WRITE !,?10,$PIECE(VAEL(1,N),"^",2)
- +9 SET DIC("A")="RX PATIENT STATUS: "
- SET DIC("B")=PSOSTA
- SET DIC(0)="QEAMZ"
- SET DIC=53
- DO ^DIC
- KILL DIC
- +10 IF +Y>0
- IF +Y'=PSOSTA
- SET DIE="^PS(55,"
- SET DR="3////"_+Y
- DO ^DIE
- End DoDot:1
- +11 QUIT
