Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSQFAS

APSQFAS.m

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