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

APSPQ1.m

Go to the documentation of this file. 
  1. APSPQ1 ; IHS/DSD/ENM - BHAM ISC/JrR/EnM - CREATE/EDIT DUE ANSWER FILE ENTRY ;  [ 09/03/97   1:30 PM ]
  1.  ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
  1.  ;IHS/DSD/ENM 9-26-95 Modified version of PSODLKP
  1.  Q
  1. EP ;IHS/DSD/ENM 9/25/95 ENTRY POINT FROM NEW RX
  1.  W !!
  1.  D NEW
  1.  S PSA=+Y W !,"SEQUENCE NUMBER: ",PSA
  1.  ;S DIC="^PSRX(",DIC(0)="EZ",X=PSONEW("RX #")
  1.  W !,"Rx #: ",PSONEW("RX #")
  1.  S PSDFN=PSODFN
  1.  G EP1
  1.  Q
  1. CREATE ;Create a new DUE ANSWER entry
  1.  W !!
  1.  D NEW
  1.  S PSA=+Y W !,"SEQUENCE NUMBER: ",PSA
  1.  S DIC="^PSRX(",DIC("A")="RX #: ",DIC(0)="QEAMZ"
  1.  D ^DIC K DIC
  1. EP1 ;IHS/DSD/ENM CALLED FROM EP
  1.  ;I $D(DUOUT)!$D(DTOUT) D DELETE G EXIT
  1.  ;S RXN=+Y,RX0=$S($D(Y(0)):Y(0),1:""),RXM=$S($D(Y(0,0)):Y(0,0),1:"")
  1.  D STUFF,QAIRE
  1.  I '$D(PSQA) D DELETE G EXIT
  1.  D DIE
  1. EXIT K CNT,D,DA,DIC,DIE,DIK,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT
  1.  K DZ,FLAG,I,K,L,LL,POP,PSA,PSDFN,PSDIG,PSHI,PSLEN,PSLO,PSMARG
  1.  K PSPROV,PSQ,PSQA,PSQN,PSQNUM,PSQP,PSTXT,PSTYP,PSWRAP,RX0,RXM,RXN,X,Y
  1.  K PSKIP,PID
  1.  W !! Q
  1.  ;
  1. DIE ;Enter here from PSODLKP,PSODEDT. Edit the DUE Answer sheet
  1.  S DIE="^PS(50.0731,",DA=PSA,DR="[PSOD DUE EDIT]" L +^PS(50.0731,DA):20 D ^DIE K DIE,DR L -^PS(50.0731,DA) K DA ;IHS/DSD/ENM 03/25/96 ']' ADDED TO TEMPLATE
  1. GETQUES F PSQNUM=0:0 S PSQNUM=$O(^PS(50.0731,PSA,1,"B",PSQNUM)) Q:'PSQNUM  S PSQN=$O(^(PSQNUM,0)),PSQP=$P(^PS(50.0731,PSA,1,PSQN,0),"^",2) I $D(^PS(50.0732,PSQP,0)) S PSQ=^(0) D ASK Q:POP
  1.  Q
  1. ASK S POP=0
  1.  D WRAP^PSODEDT
  1.  S PSTYP=$S($P(PSQ,"^",2):$P(PSQ,"^",2),1:1),PSLO=$S($P(PSQ,"^",3)]"":$P(PSQ,"^",3),1:-999),PSHI=$S($P(PSQ,"^",4)]"":$P(PSQ,"^",4),1:999)
  1.  S PSDIG=$S($P(PSQ,"^",5)]"":$P(PSQ,"^",5),1:2),PSLEN=$S($P(PSQ,"^",6)]"":$P(PSQ,"^",6),1:70)
  1.  S DIR("??")="^D QUES2^PSODEDT",DIR("A")="    ANSWER: "
  1.  S DIR(0)=$S(PSTYP=1:"S^Y:YES;N:NO;U:UNKNOWN",PSTYP=2:"F^1:"_PSLEN,PSTYP=3:"N^"_PSLO_":"_PSHI_":"_PSDIG,1:"Y")
  1.  S $P(DIR(0),"^")=$P(DIR(0),"^")_"AO"
  1.  K DIR("B")
  1.  I $D(^PS(50.0731,PSA,1,PSQN,1)),^(1)]"" S DIR("B")=^(1)
  1.  D ^DIR K DIR
  1.  I $D(DUOUT)!$D(DTOUT) S POP=1 Q
  1.  S X=$S($D(Y(0)):Y(0),1:Y)
  1.  S ^PS(50.0731,PSA,1,PSQN,1)=X
  1.  Q
  1.  ;
  1. NEW L +^PS(50.0731,0):3 E  W *7,!,"TRYING TO LOCK ^PS(50.0731,0)" G NEW
  1.  S X=$P(^PS(50.0731,0),"^",3)
  1. LOOP S X=X+1 G:$D(^PS(50.0731,X)) LOOP
  1.  K DIC,DD,DO S DIC="^PS(50.0731,",DIC(0)="XL",DIC("DR")="6///NOW"_$S($D(DUZ)#2:";5////"_DUZ,1:""),DLAYGO=50.0731,DINUM=X D FILE^DICN L -^PS(50.0731,0)
  1.  K DIC,DLAYGO,DINUM
  1.  Q:$P(Y,"^",3)
  1.  G NEW
  1.  ;
  1. QAIRE K PSQA,DA S DIR(0)="50.0731,1" D ^DIR K DIR
  1.  Q:$D(DUOUT)!$D(DTOUT)
  1.  I 'Y W !,*7,"   REQUIRED!" G QAIRE
  1.  I $S('$D(^PS(50.073,+Y,2,0)):1,'$O(^(0)):1,1:0) W !!,"  Sorry, that Questionnaire is incomplete.",!,"  Please review it before proceeding!" Q
  1.  S PSQA=+Y,$P(^PS(50.0731,PSA,0),"^",2)=PSQA
  1. MOVE S FLAG=0
  1.  F I=0:0 S I=$O(^PS(50.073,PSQA,2,I)) Q:'I  S:$D(^PS(50.0732,$P(^(I,0),"^",2),0)) ^PS(50.0731,PSA,1,I,0)=^PS(50.073,PSQA,2,I,0),$P(^PS(50.0732,$P(^(0),"^",2),0),"^",7)=1,FLAG=1
  1.  S:FLAG $P(^PS(50.073,PSQA,0),"^",4)=1,^PS(50.0731,PSA,1,0)="^50.07311IA^"_$P(^PS(50.073,PSQA,2,0),"^",3,4)
  1.  ;S DIK="^PS(50.0731,"_PSA_",1,",DA(1)=PSA D IXALL^DIK K DIK,DA
  1.  S DIK="^PS(50.0731,",DA=PSA D IX^DIK K DIK,DA
  1.  K FLAG
  1.  Q
  1. STUFF K PSKIP
  1.  ;Q:RXN<1
  1.  S PSKIP=""
  1.  ;S PSODRUG("IEN")=$P(RX0,"^",6),PSPROV=$P(RX0,"^",4),PSDFN=$P(RX0,"^",2)
  1.  S DIE="^PS(50.0731,",DA=PSA,DR="2////"_PSODRUG("IEN")_";3////"_PSONEW("IRXN")_";4////"_PSONEW("PROVIDER")_";7////"_PSDFN_";10////"_PSOSITE D ^DIE K DIE,DA,DR
  1.  S Y=PSODRUG("IEN"),C=$P(^DD(50.0731,2,0),"^",2) D Y^DIQ W:Y]"" !,"DRUG: ",Y
  1.  S Y=PSDFN,C=$P(^DD(50.0731,7,0),"^",2) D Y^DIQ W:Y]"" !,"PATIENT: ",Y
  1.  Q:'$D(^PS(50.073,"AD",PSODRUG("IEN")))
  1.  S CNT=0 F L=0:0 S L=$O(^PS(50.073,"AD",PSODRUG("IEN"),L)) Q:'L  I $P(^PS(50.073,L,0),"^",3) S CNT=CNT+1,LL=L
  1.  I CNT=1 S DIR("B")=$P(^PS(50.073,LL,0),"^") Q
  1.  ;I CNT=1 S APSPQNAM=$P(^PS(50.073,LL,0),"^") Q
  1.  W !?5,"This Drug requires the following Active Questionnaires:"
  1.  S DIC="^PS(50.073,",DIC(0)="QEM",D="B",DZ="??",DIC("S")="I $D(^PS(50.073,""AD"",PSODRUG(""IEN""),Y))&($P(^PS(50.073,Y,0),""^"",3))" D DQ^DICQ K DIC,D,DZ
  1.  Q
  1. DELETE W *7,!,"Deleting SEQUENCE NUMBER: ",PSA
  1.  S DA=PSA,DIK="^PS(50.0731," D ^DIK
  1.  Q
  1. QUES2 Q  I PSTYP=1 W !!,?5,"Enter Y for YES, N for NO, U for UNKNOWN."
  1.  I PSTYP=2 W !!,?5,"Enter a FREE TEXT answer from 1 to ",PSLEN," characters."
  1.  I PSTYP=3 W !!,?5,"Enter a number between ",PSLO," and ",PSHI,!,?5,"with a maximum of ",PSDIG," decimal digits."
  1.  W !?5,"Enter '^' to bypass."
  1.  D WRAP^PSODEDT
  1.  Q
  1. CHECK ;CHECK FOR DRUG MATCH FROM ORDER ENTRY
  1.  F PSODDRG=0:0 S PSODDRG=$O(^PS(50.073,"AD",PSODDRG)) Q:'PSODDRG  I PSODDRG=$P(^PSRX(PSONEW("IRXN"),0),"^",6) D CHECK1
  1.  Q
  1. CHECK1 F PSOST=0:0 S PSOST=$O(^PS(50.073,"AD",PSODDRG,PSOST)) Q:'PSOST  S PSOSTE=$P(^PS(50.073,PSOST,0),"^",5) Q:PSOSITE'=PSOSTE  S RXN=PSONEW("IRXN"),RX0=^PSRX(RXN,0) D CREATE1,EXIT
  1.  Q
  1. CREATE1 ;Create a new DUE ANSWER entry
  1.  W !!
  1.  D NEW
  1.  S PSA=+Y W !,"SEQUENCE NUMBER: ",PSA
  1.  S (RX0,RXM)=$S($D(^PSRX(RXN,0)):^(0),1:"")
  1.  D STUFF,QAIRE
  1.  I '$D(PSQA) D DELETE G EXIT
  1.  D DIE
  1.  Q