PSODLKP ;BHAM ISC/JrR - CREATE/EDIT DUE ANSWER FILE ENTRY ; 11/17/92 10:19
;;7.0;OUTPATIENT PHARMACY;**268**;DEC 1997;Build 9
Q
CREATE ;Create a new DUE ANSWER entry
W !!
D NEW
S PSA=+Y W !,"SEQUENCE NUMBER: ",PSA
S DIC="^PSRX(",DIC("A")="RX #: ",DIC(0)="QEAMZ"
D ^DIC K DIC
I $D(DUOUT)!$D(DTOUT) D DELETE G EXIT
S RXN=+Y,RX0=$S($D(Y(0)):Y(0),1:""),RXM=$S($D(Y(0,0)):Y(0,0),1:"")
D STUFF,QAIRE
I '$D(PSQA) D DELETE G EXIT
D DIE
EXIT K CNT,D,DA,DIC,DIE,DIK,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT
K DZ,FLAG,I,K,L,LL,PZPOP,PSA,PSDFN,PSDIG,PSDRUG,PSHI,PSLEN,PSLO,PSMARG
K PSPROV,PSQ,PSQA,PSQN,PSQNUM,PSQP,PSTXT,PSTYP,PSWRAP,RX0,RXM,RXN,X,Y
K PSKIP,PID
W !! Q
;
DIE ;Enter here from PSODLKP,PSODEDT. Edit the DUE Answer sheet
S DIE="^PS(50.0731,",DA=PSA,DR="[PSOD DUE EDIT]" L +^PS(50.0731,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!" K DA,DR,DIE,PSA Q
D ^DIE K DIE,DR L -^PS(50.0731,DA) K DA
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:PZPOP
Q
ASK S PZPOP=0
D WRAP^PSODEDT
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)
S PSDIG=$S($P(PSQ,"^",5)]"":$P(PSQ,"^",5),1:2),PSLEN=$S($P(PSQ,"^",6)]"":$P(PSQ,"^",6),1:70)
S DIR("??")="^D QUES2^PSODEDT",DIR("A")=" ANSWER: "
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")
S $P(DIR(0),"^")=$P(DIR(0),"^")_"AO"
K DIR("B")
I $D(^PS(50.0731,PSA,1,PSQN,1)),^(1)]"" S DIR("B")=^(1)
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) S PZPOP=1 Q
S X=$S($D(Y(0)):Y(0),1:Y)
S ^PS(50.0731,PSA,1,PSQN,1)=X
Q
;
NEW L +^PS(50.0731,0):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E W $C(7),!,"Trying to Lock ^PS(50.0731,0)" G NEW
S X=$P(^PS(50.0731,0),"^",3)
LOOP S X=X+1 G:$D(^PS(50.0731,X)) LOOP
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)
K DIC,DLAYGO,DINUM
Q:$P(Y,"^",3)
G NEW
;
QAIRE K PSQA,DA S DIR(0)="50.0731,1" D ^DIR K DIR
Q:$D(DUOUT)!$D(DTOUT)
I 'Y W !,$C(7)," REQUIRED!" G QAIRE
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
S PSQA=+Y,$P(^PS(50.0731,PSA,0),"^",2)=PSQA
MOVE S FLAG=0
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
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)
;S DIK="^PS(50.0731,"_PSA_",1,",DA(1)=PSA D IXALL^DIK K DIK,DA
S DIK="^PS(50.0731,",DA=PSA D IX^DIK K DIK,DA
K FLAG
Q
STUFF K PSKIP
Q:RXN<1
S PSKIP=""
S PSDRUG=$P(RX0,"^",6),PSPROV=$P(RX0,"^",4),PSDFN=$P(RX0,"^",2)
S DIE="^PS(50.0731,",DA=PSA,DR="2////"_PSDRUG_";3////"_RXN_";4////"_PSPROV_";7////"_PSDFN_";10////"_PSOSITE D ^DIE K DIE,DA,DR
S Y=PSDRUG,C=$P(^DD(50.0731,2,0),"^",2) D Y^DIQ W:Y]"" !,"DRUG: ",Y
S Y=PSDFN,C=$P(^DD(50.0731,7,0),"^",2) D Y^DIQ W:Y]"" !,"PATIENT: ",Y
Q:'$D(^PS(50.073,"AD",PSDRUG))
S CNT=0 F L=0:0 S L=$O(^PS(50.073,"AD",PSDRUG,L)) Q:'L I $P(^PS(50.073,L,0),"^",3) S CNT=CNT+1,LL=L
I CNT=1 S DIR("B")=$P(^PS(50.073,LL,0),"^") Q
W !?5,"This Drug requires the following Active Questionnaires:"
S DIC="^PS(50.073,",DIC(0)="QEM",D="B",DZ="??",DIC("S")="I $D(^PS(50.073,""AD"",PSDRUG,Y))&($P(^PS(50.073,Y,0),""^"",3))" D DQ^DICQ K DIC,D,DZ
Q
DELETE W $C(7),!,"Deleting SEQUENCE NUMBER: ",PSA
S DA=PSA,DIK="^PS(50.0731," D ^DIK
Q
QUES2 Q I PSTYP=1 W !!,?5,"Enter Y for YES, N for NO, U for UNKNOWN."
I PSTYP=2 W !!,?5,"Enter a FREE TEXT answer from 1 to ",PSLEN," characters."
I PSTYP=3 W !!,?5,"Enter a number between ",PSLO," and ",PSHI,!,?5,"with a maximum of ",PSDIG," decimal digits."
W !?5,"Enter '^' to bypass."
D WRAP^PSODEDT
Q
CHECK ;CHECK FOR DRUG MATCH FROM ORDER ENTRY
F PSODDRG=0:0 S PSODDRG=$O(^PS(50.073,"AD",PSODDRG)) Q:'PSODDRG I PSODDRG=$P(^PSRX(PSONEW("IRXN"),0),"^",6) D CHECK1
Q
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
Q
CREATE1 ;Create a new DUE ANSWER entry
W !!
D NEW
S PSA=+Y W !,"SEQUENCE NUMBER: ",PSA
S (RX0,RXM)=$S($D(^PSRX(RXN,0)):^(0),1:"")
D STUFF,QAIRE
I '$D(PSQA) D DELETE G EXIT
D DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODLKP 4730 printed Sep 23, 2025@20:03:29 Page 2
PSODLKP ;BHAM ISC/JrR - CREATE/EDIT DUE ANSWER FILE ENTRY ; 11/17/92 10:19
+1 ;;7.0;OUTPATIENT PHARMACY;**268**;DEC 1997;Build 9
+2 QUIT
CREATE ;Create a new DUE ANSWER entry
+1 WRITE !!
+2 DO NEW
+3 SET PSA=+Y
WRITE !,"SEQUENCE NUMBER: ",PSA
+4 SET DIC="^PSRX("
SET DIC("A")="RX #: "
SET DIC(0)="QEAMZ"
+5 DO ^DIC
KILL DIC
+6 IF $DATA(DUOUT)!$DATA(DTOUT)
DO DELETE
GOTO EXIT
+7 SET RXN=+Y
SET RX0=$SELECT($DATA(Y(0)):Y(0),1:"")
SET RXM=$SELECT($DATA(Y(0,0)):Y(0,0),1:"")
+8 DO STUFF
DO QAIRE
+9 IF '$DATA(PSQA)
DO DELETE
GOTO EXIT
+10 DO DIE
EXIT KILL CNT,D,DA,DIC,DIE,DIK,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT
+1 KILL DZ,FLAG,I,K,L,LL,PZPOP,PSA,PSDFN,PSDIG,PSDRUG,PSHI,PSLEN,PSLO,PSMARG
+2 KILL PSPROV,PSQ,PSQA,PSQN,PSQNUM,PSQP,PSTXT,PSTYP,PSWRAP,RX0,RXM,RXN,X,Y
+3 KILL PSKIP,PID
+4 WRITE !!
QUIT
+5 ;
DIE ;Enter here from PSODLKP,PSODEDT. Edit the DUE Answer sheet
+1 SET DIE="^PS(50.0731,"
SET DA=PSA
SET DR="[PSOD DUE EDIT]"
LOCK +^PS(50.0731,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE !,"Entry is being edited by another user. Try Later!"
KILL DA,DR,DIE,PSA
QUIT
+2 DO ^DIE
KILL DIE,DR
LOCK -^PS(50.0731,DA)
KILL DA
GETQUES FOR PSQNUM=0:0
SET PSQNUM=$ORDER(^PS(50.0731,PSA,1,"B",PSQNUM))
if 'PSQNUM
QUIT
SET PSQN=$ORDER(^(PSQNUM,0))
SET PSQP=$PIECE(^PS(50.0731,PSA,1,PSQN,0),"^",2)
IF $DATA(^PS(50.0732,PSQP,0))
SET PSQ=^(0)
DO ASK
if PZPOP
QUIT
+1 QUIT
ASK SET PZPOP=0
+1 DO WRAP^PSODEDT
+2 SET PSTYP=$SELECT($PIECE(PSQ,"^",2):$PIECE(PSQ,"^",2),1:1)
SET PSLO=$SELECT($PIECE(PSQ,"^",3)]"":$PIECE(PSQ,"^",3),1:-999)
SET PSHI=$SELECT($PIECE(PSQ,"^",4)]"":$PIECE(PSQ,"^",4),1:999)
+3 SET PSDIG=$SELECT($PIECE(PSQ,"^",5)]"":$PIECE(PSQ,"^",5),1:2)
SET PSLEN=$SELECT($PIECE(PSQ,"^",6)]"":$PIECE(PSQ,"^",6),1:70)
+4 SET DIR("??")="^D QUES2^PSODEDT"
SET DIR("A")=" ANSWER: "
+5 SET DIR(0)=$SELECT(PSTYP=1:"S^Y:YES;N:NO;U:UNKNOWN",PSTYP=2:"F^1:"_PSLEN,PSTYP=3:"N^"_PSLO_":"_PSHI_":"_PSDIG,1:"Y")
+6 SET $PIECE(DIR(0),"^")=$PIECE(DIR(0),"^")_"AO"
+7 KILL DIR("B")
+8 IF $DATA(^PS(50.0731,PSA,1,PSQN,1))
IF ^(1)]""
SET DIR("B")=^(1)
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DUOUT)!$DATA(DTOUT)
SET PZPOP=1
QUIT
+11 SET X=$SELECT($DATA(Y(0)):Y(0),1:Y)
+12 SET ^PS(50.0731,PSA,1,PSQN,1)=X
+13 QUIT
+14 ;
NEW LOCK +^PS(50.0731,0):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE $CHAR(7),!,"Trying to Lock ^PS(50.0731,0)"
GOTO NEW
+1 SET X=$PIECE(^PS(50.0731,0),"^",3)
LOOP SET X=X+1
if $DATA(^PS(50.0731,X))
GOTO LOOP
+1 KILL DIC,DD,DO
SET DIC="^PS(50.0731,"
SET DIC(0)="XL"
SET DIC("DR")="6///NOW"_$SELECT($DATA(DUZ)#2:";5////"_DUZ,1:"")
SET DLAYGO=50.0731
SET DINUM=X
DO FILE^DICN
LOCK -^PS(50.0731,0)
+2 KILL DIC,DLAYGO,DINUM
+3 if $PIECE(Y,"^",3)
QUIT
+4 GOTO NEW
+5 ;
QAIRE KILL PSQA,DA
SET DIR(0)="50.0731,1"
DO ^DIR
KILL DIR
+1 if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+2 IF 'Y
WRITE !,$CHAR(7)," REQUIRED!"
GOTO QAIRE
+3 IF $SELECT('$DATA(^PS(50.073,+Y,2,0)):1,'$ORDER(^(0)):1,1:0)
WRITE !!," Sorry, that Questionnaire is incomplete.",!," Please review it before proceeding!"
QUIT
+4 SET PSQA=+Y
SET $PIECE(^PS(50.0731,PSA,0),"^",2)=PSQA
MOVE SET FLAG=0
+1 FOR I=0:0
SET I=$ORDER(^PS(50.073,PSQA,2,I))
if 'I
QUIT
if $DATA(^PS(50.0732,$PIECE(^(I,0),"^",2),0))
SET ^PS(50.0731,PSA,1,I,0)=^PS(50.073,PSQA,2,I,0)
SET $PIECE(^PS(50.0732,$PIECE(^(0),"^",2),0),"^",7)=1
SET FLAG=1
+2 if FLAG
SET $PIECE(^PS(50.073,PSQA,0),"^",4)=1
SET ^PS(50.0731,PSA,1,0)="^50.07311IA^"_$PIECE(^PS(50.073,PSQA,2,0),"^",3,4)
+3 ;S DIK="^PS(50.0731,"_PSA_",1,",DA(1)=PSA D IXALL^DIK K DIK,DA
+4 SET DIK="^PS(50.0731,"
SET DA=PSA
DO IX^DIK
KILL DIK,DA
+5 KILL FLAG
+6 QUIT
STUFF KILL PSKIP
+1 if RXN<1
QUIT
+2 SET PSKIP=""
+3 SET PSDRUG=$PIECE(RX0,"^",6)
SET PSPROV=$PIECE(RX0,"^",4)
SET PSDFN=$PIECE(RX0,"^",2)
+4 SET DIE="^PS(50.0731,"
SET DA=PSA
SET DR="2////"_PSDRUG_";3////"_RXN_";4////"_PSPROV_";7////"_PSDFN_";10////"_PSOSITE
DO ^DIE
KILL DIE,DA,DR
+5 SET Y=PSDRUG
SET C=$PIECE(^DD(50.0731,2,0),"^",2)
DO Y^DIQ
if Y]""
WRITE !,"DRUG: ",Y
+6 SET Y=PSDFN
SET C=$PIECE(^DD(50.0731,7,0),"^",2)
DO Y^DIQ
if Y]""
WRITE !,"PATIENT: ",Y
+7 if '$DATA(^PS(50.073,"AD",PSDRUG))
QUIT
+8 SET CNT=0
FOR L=0:0
SET L=$ORDER(^PS(50.073,"AD",PSDRUG,L))
if 'L
QUIT
IF $PIECE(^PS(50.073,L,0),"^",3)
SET CNT=CNT+1
SET LL=L
+9 IF CNT=1
SET DIR("B")=$PIECE(^PS(50.073,LL,0),"^")
QUIT
+10 WRITE !?5,"This Drug requires the following Active Questionnaires:"
+11 SET DIC="^PS(50.073,"
SET DIC(0)="QEM"
SET D="B"
SET DZ="??"
SET DIC("S")="I $D(^PS(50.073,""AD"",PSDRUG,Y))&($P(^PS(50.073,Y,0),""^"",3))"
DO DQ^DICQ
KILL DIC,D,DZ
+12 QUIT
DELETE WRITE $CHAR(7),!,"Deleting SEQUENCE NUMBER: ",PSA
+1 SET DA=PSA
SET DIK="^PS(50.0731,"
DO ^DIK
+2 QUIT
QUES2 QUIT
IF PSTYP=1
WRITE !!,?5,"Enter Y for YES, N for NO, U for UNKNOWN."
+1 IF PSTYP=2
WRITE !!,?5,"Enter a FREE TEXT answer from 1 to ",PSLEN," characters."
+2 IF PSTYP=3
WRITE !!,?5,"Enter a number between ",PSLO," and ",PSHI,!,?5,"with a maximum of ",PSDIG," decimal digits."
+3 WRITE !?5,"Enter '^' to bypass."
+4 DO WRAP^PSODEDT
+5 QUIT
CHECK ;CHECK FOR DRUG MATCH FROM ORDER ENTRY
+1 FOR PSODDRG=0:0
SET PSODDRG=$ORDER(^PS(50.073,"AD",PSODDRG))
if 'PSODDRG
QUIT
IF PSODDRG=$PIECE(^PSRX(PSONEW("IRXN"),0),"^",6)
DO CHECK1
+2 QUIT
CHECK1 FOR PSOST=0:0
SET PSOST=$ORDER(^PS(50.073,"AD",PSODDRG,PSOST))
if 'PSOST
QUIT
SET PSOSTE=$PIECE(^PS(50.073,PSOST,0),"^",5)
if PSOSITE'=PSOSTE
QUIT
SET RXN=PSONEW("IRXN")
SET RX0=^PSRX(RXN,0)
DO CREATE1
DO EXIT
+1 QUIT
CREATE1 ;Create a new DUE ANSWER entry
+1 WRITE !!
+2 DO NEW
+3 SET PSA=+Y
WRITE !,"SEQUENCE NUMBER: ",PSA
+4 SET (RX0,RXM)=$SELECT($DATA(^PSRX(RXN,0)):^(0),1:"")
+5 DO STUFF
DO QAIRE
+6 IF '$DATA(PSQA)
DO DELETE
GOTO EXIT
+7 DO DIE
+8 QUIT
