APSQFAS ;IHS/ASDS/ENM/POC - NEW RX ORDER MAIN DRIVER USING FAST OPTION
;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
;---------------------------------------------------------------
START ;EP
D EOJ
S (PSONEW("QFLG"),PSONEW("DFLG"))=0
G:$G(PSODFN)']"" END
I $P($G(PSOPAR),"^",4)'=1,$P($G(PSOPAR),"^",21)=1 D DISPLAY
I PSONEW("QFLG") S PSORX("QFLG")=1 G END
D:$P($G(PSOPAR),"^",7)=1 ASK G:PSONEW("QFLG") END ; Asks if want to do RX
; ----- ----- ----- ----- -----
;IHS/DSD/ENM 11/4/93
IHSV ; hook to store data for patient in PCC parameter array for later use
I $P(%APSITE,U,15)="Y" D ^APSPCCV
I $D(^DPT(PSODFN,.1)) ; RESET NAKED FOR CODE WHICH FOLLOWS
; ----- ----- ----- ----- -----
;D ^PSONEW1 ; Continue order entry
D ^APSQFAS1 ; Continue order entry
I PSONEW("QFLG") S PSORX("QFLG")=1 G END ;BACKUP TO PSORX AGAIN
I PSONEW("DFLG") Q ;NO NEED TO DELETE NUMBER AS NOT ASSIGNED YET
;CHANGED NEXT FEW LINES FOR LISTER
;D ^APSQFAS2
D EN^VALM("APSQDIS")
I '$D(DRUGPICK) S PSONEW("QFLG")=1
I PSONEW("QFLG") Q
DIQ ;S APSQHIT=0 F S APSQHIT=$O(DRUG(APSQHIT)) Q:APSQHIT="" D D ^APSQFAS3,FIN
S APSQDG=0 F S APSQDG=$O(DRUGPICK(APSQDG)) Q:APSQDG="" D D ^APSQFAS3,FIN
.;S APSQDG=+DRUG(APSQHIT)
.;Q:'APSQDG
.D GETS^DIQ(9009035.3,APSQDG_",","*","I","APSQ","ERR")
.M APSQF=APSQ(9009035.3,APSQDG_",") K APSQ ;EASIER TO WORK WITH
K APSQF ;GET RID OF THESE FOR NEXT LOOP
;K DRUG ;MOD 11/24/98 IHS/OKCAO/POC
K DRUGPICK
;END OF CHANGES
Q
FIN ;FINISH UP
;
I PSONEW("QFLG") G END
I PSONEW("DFLG") W !,*7,"RX DELETED",! Q ;G START FAST OPTION
IHSP ;---- ---- ---- ---- ---- ----
;IHS PCC HOOK (CREATE APSP PRIMARY CARE VISIT ENTRY)
I $P(%APSITE,U,35)=1 D ^APSPCVRX ;IHS/DSD/ENM 11/4/93
;---- ---- ---- ---- ---- ----
;D:$P($G(PSOPAR),"^",7)=1 AUTO^PSONRXN I $P($G(PSOPAR),"^",7)'=1 S PSOX=PSONEW("RX #") D CHECK^PSONRXN
D AUTO^PSONRXN
I PSONEW("DFLG")!PSONEW("QFLG") D DEL Q ;G START FAST OPTION
;Set chronic medication data in ^PSRX(,9999999)
;D ^PSOZCM ;IHS/DSD/ENM 11/8/93 NOW HANDLED IN PSODIR1
EXD ;IHS/DSD/ENM 4/20/94 Check %APSITE P11 for Exp Date
;I $P(%APSITE,U,11)]"" D ^PSOZEXP ;IHS/DSD/ENM DISABLED 12/22/94
;S PSONEW("RELEASED DATE/TIME")=PSONEW("ISSUE DATE") ;IHS/DSD/ENM 4/18/94
D ^PSONEW2 I PSONEW("DFLG") D DEL Q ;G START ; Asks if correct FAST OPTION
D EN^PSON52(.PSONEW) ; Files entry in File 52
I $G(APSP("CM"))]"" S $P(^PSRX(PSONEW("IRXN"),9999999),"^",2)=APSP("CM") ;IHS/DSD/ENM 09/19/96 SET CHRONIC MED
;I $D(^XUSEC("PSORPH",DUZ)) S APSPZRP=PSONEW("IRXN") ;IHS/DSD/ENM 12/1/95 VAR USED IN PSORX
I $D(^XUSEC("PSORPH",DUZ)) S APSPZRP=$G(PSORX("PSOL",1)) ;IHS/DSD/ENM 12/1/95 VAR USED IN PSORX
;--- --- --- --- ---
;I $D(^XUSEC("PSORPH",DUZ)) D ;IHS/DSD/ENM 11/30/95 RELEASE DT SET
;.S RXP=PSONEW("IRXN"),PSRH=DUZ,PSIN=$P($G(^PS(59.7,1,49.99)),"^",2)
;.D ^APSPDISP
;D NOW^%DTC S APSPZRD=% ;IHS/DSD/ENM USED FOR RELEASE DATE/TIME f31
;S DR="31////"_APSPZRD,DIE="^PSRX(",DA=PSONEW("IRXN") D ^DIE
EXDT ;EXPIRATION DATE SET FOR 9999999 NODE ;IHS/DSD/ENM 4/20/94
;I $D(P(99)) S ^PSRX(PSONEW("IRXN"),9999999)=$S('$D(^(9999999)):P(99),1:P(99)_U_$P(^(9999999),U,2,9))
I $D(P(99)) S $P(^PSRX(PSONEW("IRXN"),9999999),"^")=+P(99) ;IHS/DSD/ENM 09/19/96
D NPSOSD^PSOUTIL(.PSONEW) ; Adds newly added rx to PSOSD array
IHSH ;
;IHS/DSD/ENM 11/22/95 HOOK FOR DATA LINK TO IHS/PCC
S APSPDOC1=$P($G(^VA(200,PSONEW("PROVIDER"),0)),U,16),APCDALVR("APCDTPRV")=$S($P($G(^AUTTSITE(1,0)),U,22):PSONEW("PROVIDER"),1:APSPDOC1) ;IHS/DSD/ENM 11/22/95
;IHS/DSD/ENM NEXT LINE COPIED AND PROVIDER VALUE CHANGED 11/22/95
;I $P(%APSITE,U,15)="Y" S APSRX=PSONEW("IRXN"),APCDALVR("APCDDATE")=PSONEW("ISSUE DATE"),APCDALVR("APCDTPRV")=PSONEW("PROVIDER") S:PSONEW("PATIENT STATUS")'=1 APCDALVR("APCDCAT")="I" D ^APSPCCN
;IHS/DSD/ENM 08/13/97 NEXT LINE COPIED AND NEW DATE VAR PASSED TO PCC
;I $P(%APSITE,U,15)="Y" S APSRX=PSONEW("IRXN"),APCDALVR("APCDDATE")=PSONEW("ISSUE DATE") S:PSONEW("PATIENT STATUS")'=1 APCDALVR("APCDCAT")="I" D ^APSPCCN
I $P(%APSITE,U,15)="Y" S APSRX=PSONEW("IRXN"),APCDALVR("APCDDATE")=APSEFDT S:PSONEW("PATIENT STATUS")'=1 APCDALVR("APCDCAT")="I" D ^APSPCCN
Q ;G START FAST OPTION
END D EOJ ; Clean up
Q
;
;----------------------------------------------------------------
DISPLAY ;
;S (PSOOPT,PSOQFLG)=0 D ^PSODSPL
S PSOOPT=-1,PSOQFLG=0 D ^PSODSPL ;IHS/DSD/ENM 3/29/94
S APSPFLG=1 ;IHS/DSD/ENM 3/29/94
I PSOQFLG S PSONEW("QFLG")=1
K PSOQFLG
Q
;
ASK ;
S DIR(0)="SB^Y:YES;N:NO;P:PROFILE;R:REFILL;A:ALLERGIES/REACTIONS;G:GOTO NEW",DIR("B")="Y"
S DIR("A")="NEW FAST RX FOR "_$G(PSORX("NAME"))_" ?"
S DIR("?",1)="Enter a Y for Yes, N for No, a P to see a Profile,"
S DIR("?")="a R to do refills if any are allowed or A to review Allergies."
S DIR("?",2)="Enter a G for GOTO NEW"
D ^DIR K DIR
I $D(DIRUT) S (PSONEW("QFLG"),PSORX("QFLG"))=1 G ASKX
I $G(Y)="N" S PSONEW("QFLG")=1 G ASKX
;IHS/DSD/ENM PSOBUILD CALL REMOVED IN PATCH 18 ;09-14-94
I "Pp"[Y D ^PSOBUILD,^PSODSPL G ASK
I "Rr"[Y S (PSORX("DO REFILL"),PSONEW("QFLG"))=1
I "Aa"[Y D GMRA^PSODEM G ASK
;I "Gg"[Y S APSQFNEW=1,PSONEW("QFLG")=1 ;D INIT^PSORX ;OPTION IHS/OKCAO/POC
I "Gg"[Y S APSQFNEW=1,PSONEW("QFLG")=1,PSOFROM="NEW" ;D INIT^PSORX ;OPTION IHS/OKCAO/POC
ASKX ;
K DIRUT,DTOUT,DUOUT,X,Y
Q
;
DEL ;
W !,*7,"RX DELETED",!
I $P($G(PSOPAR),"^",7)=1 D
. S DIE="^PS(59,",DA=PSOSITE,PSOY=$O(PSONEW("OLD LAST RX#",""))
. S PSOX=PSONEW("OLD LAST RX#",PSOY)
. L +^PS(59,+PSOSITE,PSOY)
. S DR=$S(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
. D:PSOX<$P(^PS(59,+PSOSITE,PSOY),"^",3) ^DIE K DIE,X,Y
. L -^PS(59,+PSOSITE,PSOY)
. K PSOX,PSOY Q
EOJ ;
L:$D(PSONEW("RX #")) -PSONRXN(PSONEW("RX #")) ; +Lock set in PSONRXN
K PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,APSPZRD
K APSQFOPT ;FOR DAYS SUPPLY OPTION CALCULATING
K APSPCM,APSPCA,APSPDOC1
K:'$D(APSQFNEW) PSONEW
Q
APSQFAS ;IHS/ASDS/ENM/POC - NEW RX ORDER MAIN DRIVER USING FAST OPTION
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
+2 ;---------------------------------------------------------------
START ;EP
+1 DO EOJ
+2 SET (PSONEW("QFLG"),PSONEW("DFLG"))=0
+3 IF $GET(PSODFN)']""
GOTO END
+4 IF $PIECE($GET(PSOPAR),"^",4)'=1
IF $PIECE($GET(PSOPAR),"^",21)=1
DO DISPLAY
+5 IF PSONEW("QFLG")
SET PSORX("QFLG")=1
GOTO END
+6 ; Asks if want to do RX
IF $PIECE($GET(PSOPAR),"^",7)=1
DO ASK
IF PSONEW("QFLG")
GOTO END
+7 ; ----- ----- ----- ----- -----
+8 ;IHS/DSD/ENM 11/4/93
IHSV ; hook to store data for patient in PCC parameter array for later use
+1 IF $PIECE(%APSITE,U,15)="Y"
DO ^APSPCCV
+2 ; RESET NAKED FOR CODE WHICH FOLLOWS
IF $DATA(^DPT(PSODFN,.1))
+3 ; ----- ----- ----- ----- -----
+4 ;D ^PSONEW1 ; Continue order entry
+5 ; Continue order entry
DO ^APSQFAS1
+6 ;BACKUP TO PSORX AGAIN
IF PSONEW("QFLG")
SET PSORX("QFLG")=1
GOTO END
+7 ;NO NEED TO DELETE NUMBER AS NOT ASSIGNED YET
IF PSONEW("DFLG")
QUIT
+8 ;CHANGED NEXT FEW LINES FOR LISTER
+9 ;D ^APSQFAS2
+10 DO EN^VALM("APSQDIS")
+11 IF '$DATA(DRUGPICK)
SET PSONEW("QFLG")=1
+12 IF PSONEW("QFLG")
QUIT
DIQ ;S APSQHIT=0 F S APSQHIT=$O(DRUG(APSQHIT)) Q:APSQHIT="" D D ^APSQFAS3,FIN
+1 SET APSQDG=0
FOR
SET APSQDG=$ORDER(DRUGPICK(APSQDG))
IF APSQDG=""
QUIT
Begin DoDot:1
+2 ;S APSQDG=+DRUG(APSQHIT)
+3 ;Q:'APSQDG
+4 DO GETS^DIQ(9009035.3,APSQDG_",","*","I","APSQ","ERR")
+5 ;EASIER TO WORK WITH
MERGE APSQF=APSQ(9009035.3,APSQDG_",")
KILL APSQ
End DoDot:1
DO ^APSQFAS3
DO FIN
+6 ;GET RID OF THESE FOR NEXT LOOP
KILL APSQF
+7 ;K DRUG ;MOD 11/24/98 IHS/OKCAO/POC
+8 KILL DRUGPICK
+9 ;END OF CHANGES
+10 QUIT
FIN ;FINISH UP
+1 ;
+2 IF PSONEW("QFLG")
GOTO END
+3 ;G START FAST OPTION
IF PSONEW("DFLG")
WRITE !,*7,"RX DELETED",!
QUIT
IHSP ;---- ---- ---- ---- ---- ----
+1 ;IHS PCC HOOK (CREATE APSP PRIMARY CARE VISIT ENTRY)
+2 ;IHS/DSD/ENM 11/4/93
IF $PIECE(%APSITE,U,35)=1
DO ^APSPCVRX
+3 ;---- ---- ---- ---- ---- ----
+4 ;D:$P($G(PSOPAR),"^",7)=1 AUTO^PSONRXN I $P($G(PSOPAR),"^",7)'=1 S PSOX=PSONEW("RX #") D CHECK^PSONRXN
+5 DO AUTO^PSONRXN
+6 ;G START FAST OPTION
IF PSONEW("DFLG")!PSONEW("QFLG")
DO DEL
QUIT
+7 ;Set chronic medication data in ^PSRX(,9999999)
+8 ;D ^PSOZCM ;IHS/DSD/ENM 11/8/93 NOW HANDLED IN PSODIR1
EXD ;IHS/DSD/ENM 4/20/94 Check %APSITE P11 for Exp Date
+1 ;I $P(%APSITE,U,11)]"" D ^PSOZEXP ;IHS/DSD/ENM DISABLED 12/22/94
+2 ;S PSONEW("RELEASED DATE/TIME")=PSONEW("ISSUE DATE") ;IHS/DSD/ENM 4/18/94
+3 ;G START ; Asks if correct FAST OPTION
DO ^PSONEW2
IF PSONEW("DFLG")
DO DEL
QUIT
+4 ; Files entry in File 52
DO EN^PSON52(.PSONEW)
+5 ;IHS/DSD/ENM 09/19/96 SET CHRONIC MED
IF $GET(APSP("CM"))]""
SET $PIECE(^PSRX(PSONEW("IRXN"),9999999),"^",2)=APSP("CM")
+6 ;I $D(^XUSEC("PSORPH",DUZ)) S APSPZRP=PSONEW("IRXN") ;IHS/DSD/ENM 12/1/95 VAR USED IN PSORX
+7 ;IHS/DSD/ENM 12/1/95 VAR USED IN PSORX
IF $DATA(^XUSEC("PSORPH",DUZ))
SET APSPZRP=$GET(PSORX("PSOL",1))
+8 ;--- --- --- --- ---
+9 ;I $D(^XUSEC("PSORPH",DUZ)) D ;IHS/DSD/ENM 11/30/95 RELEASE DT SET
+10 ;.S RXP=PSONEW("IRXN"),PSRH=DUZ,PSIN=$P($G(^PS(59.7,1,49.99)),"^",2)
+11 ;.D ^APSPDISP
+12 ;D NOW^%DTC S APSPZRD=% ;IHS/DSD/ENM USED FOR RELEASE DATE/TIME f31
+13 ;S DR="31////"_APSPZRD,DIE="^PSRX(",DA=PSONEW("IRXN") D ^DIE
EXDT ;EXPIRATION DATE SET FOR 9999999 NODE ;IHS/DSD/ENM 4/20/94
+1 ;I $D(P(99)) S ^PSRX(PSONEW("IRXN"),9999999)=$S('$D(^(9999999)):P(99),1:P(99)_U_$P(^(9999999),U,2,9))
+2 ;IHS/DSD/ENM 09/19/96
IF $DATA(P(99))
SET $PIECE(^PSRX(PSONEW("IRXN"),9999999),"^")=+P(99)
+3 ; Adds newly added rx to PSOSD array
DO NPSOSD^PSOUTIL(.PSONEW)
IHSH ;
+1 ;IHS/DSD/ENM 11/22/95 HOOK FOR DATA LINK TO IHS/PCC
+2 ;IHS/DSD/ENM 11/22/95
SET APSPDOC1=$PIECE($GET(^VA(200,PSONEW("PROVIDER"),0)),U,16)
SET APCDALVR("APCDTPRV")=$SELECT($PIECE($GET(^AUTTSITE(1,0)),U,22):PSONEW("PROVIDER"),1:APSPDOC1)
+3 ;IHS/DSD/ENM NEXT LINE COPIED AND PROVIDER VALUE CHANGED 11/22/95
+4 ;I $P(%APSITE,U,15)="Y" S APSRX=PSONEW("IRXN"),APCDALVR("APCDDATE")=PSONEW("ISSUE DATE"),APCDALVR("APCDTPRV")=PSONEW("PROVIDER") S:PSONEW("PATIENT STATUS")'=1 APCDALVR("APCDCAT")="I" D ^APSPCCN
+5 ;IHS/DSD/ENM 08/13/97 NEXT LINE COPIED AND NEW DATE VAR PASSED TO PCC
+6 ;I $P(%APSITE,U,15)="Y" S APSRX=PSONEW("IRXN"),APCDALVR("APCDDATE")=PSONEW("ISSUE DATE") S:PSONEW("PATIENT STATUS")'=1 APCDALVR("APCDCAT")="I" D ^APSPCCN
+7 IF $PIECE(%APSITE,U,15)="Y"
SET APSRX=PSONEW("IRXN")
SET APCDALVR("APCDDATE")=APSEFDT
IF PSONEW("PATIENT STATUS")'=1
SET APCDALVR("APCDCAT")="I"
DO ^APSPCCN
+8 ;G START FAST OPTION
QUIT
END ; Clean up
DO EOJ
+1 QUIT
+2 ;
+3 ;----------------------------------------------------------------
DISPLAY ;
+1 ;S (PSOOPT,PSOQFLG)=0 D ^PSODSPL
+2 ;IHS/DSD/ENM 3/29/94
SET PSOOPT=-1
SET PSOQFLG=0
DO ^PSODSPL
+3 ;IHS/DSD/ENM 3/29/94
SET APSPFLG=1
+4 IF PSOQFLG
SET PSONEW("QFLG")=1
+5 KILL PSOQFLG
+6 QUIT
+7 ;
ASK ;
+1 SET DIR(0)="SB^Y:YES;N:NO;P:PROFILE;R:REFILL;A:ALLERGIES/REACTIONS;G:GOTO NEW"
SET DIR("B")="Y"
+2 SET DIR("A")="NEW FAST RX FOR "_$GET(PSORX("NAME"))_" ?"
+3 SET DIR("?",1)="Enter a Y for Yes, N for No, a P to see a Profile,"
+4 SET DIR("?")="a R to do refills if any are allowed or A to review Allergies."
+5 SET DIR("?",2)="Enter a G for GOTO NEW"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
SET (PSONEW("QFLG"),PSORX("QFLG"))=1
GOTO ASKX
+8 IF $GET(Y)="N"
SET PSONEW("QFLG")=1
GOTO ASKX
+9 ;IHS/DSD/ENM PSOBUILD CALL REMOVED IN PATCH 18 ;09-14-94
+10 IF "Pp"[Y
DO ^PSOBUILD
DO ^PSODSPL
GOTO ASK
+11 IF "Rr"[Y
SET (PSORX("DO REFILL"),PSONEW("QFLG"))=1
+12 IF "Aa"[Y
DO GMRA^PSODEM
GOTO ASK
+13 ;I "Gg"[Y S APSQFNEW=1,PSONEW("QFLG")=1 ;D INIT^PSORX ;OPTION IHS/OKCAO/POC
+14 ;D INIT^PSORX ;OPTION IHS/OKCAO/POC
IF "Gg"[Y
SET APSQFNEW=1
SET PSONEW("QFLG")=1
SET PSOFROM="NEW"
ASKX ;
+1 KILL DIRUT,DTOUT,DUOUT,X,Y
+2 QUIT
+3 ;
DEL ;
+1 WRITE !,*7,"RX DELETED",!
+2 IF $PIECE($GET(PSOPAR),"^",7)=1
Begin DoDot:1
+3 SET DIE="^PS(59,"
SET DA=PSOSITE
SET PSOY=$ORDER(PSONEW("OLD LAST RX#",""))
+4 SET PSOX=PSONEW("OLD LAST RX#",PSOY)
+5 LOCK +^PS(59,+PSOSITE,PSOY)
+6 SET DR=$SELECT(PSOY=8:"2003////"_PSOX,PSOY=3:"1002.1////"_PSOX,1:"2003////"_PSOX)
+7 IF PSOX<$PIECE(^PS(59,+PSOSITE,PSOY),"^",3)
DO ^DIE
KILL DIE,X,Y
+8 LOCK -^PS(59,+PSOSITE,PSOY)
+9 KILL PSOX,PSOY
QUIT
End DoDot:1
EOJ ;
+1 ; +Lock set in PSONRXN
IF $DATA(PSONEW("RX #"))
LOCK -PSONRXN(PSONEW("RX #"))
+2 KILL PSODRUG,ANQDATA,LSI,C,MAX,MIN,NDF,REF,SIG,SER,PSOFLAG,PSOHI,PSOLO,APSPZRD
+3 ;FOR DAYS SUPPLY OPTION CALCULATING
KILL APSQFOPT
+4 KILL APSPCM,APSPCA,APSPDOC1
+5 IF '$DATA(APSQFNEW)
KILL PSONEW
+6 QUIT
