PSODEDT ;BHAM ISC/SAB - edit due answer sheet ; 06/03/92 17:26
;;7.0;OUTPATIENT PHARMACY;**2,268**;DEC 1997;Build 9
SEQNUM K DIC S DIC="^PS(50.0731,",DIC("A")="Select DUE ANSWER SEQUENCE NUMBER ('^S' to Search): ",DIC(0)="QEAM" D ^DIC K DIC
G:(X="^")!($D(DTOUT))!(X="") EXIT
S PSA=+Y
I (PSA<1)&($E(X,1,2)="^S") D SEARCH G:PSA<1 SEQNUM
I PSA<1 W " ??",$C(7) G SEQNUM
EDIT S DIE="^PS(50.0731,",(DA,PSODUEL)=PSA,DR=".01" L +^PS(50.0731,PSODUEL):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!" G EXIT
D ^DIE L -^PS(50.0731,PSODUEL) K DIE,DA,DR,PSODUEL
G:$D(Y) EXIT
D:$D(^PS(50.0731,PSA,0)) DIE^PSODLKP
G PSODEDT
EXIT K ^TMP("PSOD",$J)
K DA,DIC,DIE,DIQ,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,DX,DY,FLD,I,ID,IX,IXN
K IXS,N,PID,PSDPOP,PSA,PSCH,PSDIG,PSEED,PSFLAG,PSHI,PSHIT,PSIX,PSL,PSLEN
K PSLO,PSMARG,PSQ,PSQN,PSQNUM,PSQP,PSTXT,PSTYP,PSWRAP,X,Y
QUIT
;
SEARCH K DIR,DUOUT,DTOUT,PSCH,PSIX,PID,^TMP("PSOD",$J)
W !!!!!,"If you do not know the Sequence Number, you may search by any or all of the",!,"following fields: "
W !!?5,"QUESTIONNAIRE",!?5,"DRUG",!?5,"PROVIDER",!!?5,"Type '^' to exit.",!
S PSFLAG=0
F FLD=1,2,4 Q:$D(DTOUT)!$D(DUOUT) S DIR(0)="50.0731,"_FLD_"O" D ASK
Q:'PSFLAG
S IXS=""
F FLD=1,2,4 I $D(PSCH(FLD)),PSCH(FLD) S IXS=$S(FLD=1:"Q",FLD=2:"D",1:"P")_IXS
I $L(IXS)>1 S PSEED=$E(IXS) F N=0:0 S IX=PSEED D GETIXN S N=$O(^PS(50.0731,PSEED,PSCH(IXN),N)) Q:'N S PSHIT=1 D GETN I PSHIT S ^TMP("PSOD",$J,N)=""
I $L(IXS)=1 S IX=IXS D GETIXN F N=0:0 S N=$O(^PS(50.0731,IXS,PSCH(IXN),N)) Q:'N S ^TMP("PSOD",$J,N)=""
I '$D(^TMP("PSOD",$J)) W !!?5,"No Matches Found!!!",!! Q
I '$O(^TMP("PSOD",$J,$O(^TMP("PSOD",$J,0)))) S PSA=$O(^TMP("PSOD",$J,0)) W !! Q
S PSDPOP=0
CHOICES W !!?2,"CHOOSE FROM...",!!
S DIC="^PS(50.0731,",DR="1:9",DIQ="PID",DIQ(0)="E"
S PSL=$S($D(IOSL):IOSL-3,1:21),(DX,DY)=0 X ^%ZOSF("XY")
F N=0:0 S N=$O(^TMP("PSOD",$J,N)) Q:'N D DISPLAY Q:PSDPOP
K DIC,DIQ
S PSA=0
Q
ASK K DA
D ^DIR K DIR
S PSCH(FLD)=+Y,PSFLAG=PSFLAG+Y
Q
GETN F I=2:1:$L(IXS) S IX=$E(IXS,I) D GETIXN S PSHIT=PSHIT*$D(^PS(50.0731,IX,PSCH(IXN),N))
Q
GETIXN S IXN=$S(IX="Q":1,IX="D":2,1:4)
Q
DISPLAY I $Y,$Y>PSL S (DX,DY)=0 X ^%ZOSF("XY") S DIR(0)="E" D ^DIR W $C(13),$J("",45),$C(13) I 'Y S PSDPOP=1 Q
S (PSQNUM,DA)=N,PSQ=""
D EN^DIQ1
F ID=.01:0 S ID=$O(PID(50.0731,DA,ID)) Q:'ID S PSQ=PSQ_PID(50.0731,DA,ID,"E")_$S($L(PID(50.0731,DA,ID,"E")):"/",1:"")
D WRAP
Q
WRAP ;Enter here from PSODACT,PSODLKP,PSODEDT to format Question
;Needs PSQ=text, PSQNUM=question number
NEW I,K
S PSTXT=$P(PSQ,"^") W !,PSQNUM,"."
S PSWRAP=1,PSMARG=$S('$G(PSORM):80,$D(IOM):IOM,1:80)-5
W1 S:$L(PSTXT)<PSMARG PSWRAP(PSWRAP)=PSTXT I $L(PSTXT)'<PSMARG F I=PSMARG:-1:0 I $E(PSTXT,I)?1P S PSWRAP(PSWRAP)=$E(PSTXT,1,I),PSTXT=$E(PSTXT,I+1,999),PSWRAP=PSWRAP+1 G W1
F K=1:1:PSWRAP W ?($L(PSQNUM)+2),PSWRAP(K),!
Q
QUES2 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 carriage return to bypass."
W !?5,"Enter '^' to exit."
D WRAP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEDT 3281 printed Oct 16, 2024@18:27:27 Page 2
PSODEDT ;BHAM ISC/SAB - edit due answer sheet ; 06/03/92 17:26
+1 ;;7.0;OUTPATIENT PHARMACY;**2,268**;DEC 1997;Build 9
SEQNUM KILL DIC
SET DIC="^PS(50.0731,"
SET DIC("A")="Select DUE ANSWER SEQUENCE NUMBER ('^S' to Search): "
SET DIC(0)="QEAM"
DO ^DIC
KILL DIC
+1 if (X="^")!($DATA(DTOUT))!(X="")
GOTO EXIT
+2 SET PSA=+Y
+3 IF (PSA<1)&($EXTRACT(X,1,2)="^S")
DO SEARCH
if PSA<1
GOTO SEQNUM
+4 IF PSA<1
WRITE " ??",$CHAR(7)
GOTO SEQNUM
EDIT SET DIE="^PS(50.0731,"
SET (DA,PSODUEL)=PSA
SET DR=".01"
LOCK +^PS(50.0731,PSODUEL):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE !,"Entry is being edited by another user. Try Later!"
GOTO EXIT
+1 DO ^DIE
LOCK -^PS(50.0731,PSODUEL)
KILL DIE,DA,DR,PSODUEL
+2 if $DATA(Y)
GOTO EXIT
+3 if $DATA(^PS(50.0731,PSA,0))
DO DIE^PSODLKP
+4 GOTO PSODEDT
EXIT KILL ^TMP("PSOD",$JOB)
+1 KILL DA,DIC,DIE,DIQ,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,DX,DY,FLD,I,ID,IX,IXN
+2 KILL IXS,N,PID,PSDPOP,PSA,PSCH,PSDIG,PSEED,PSFLAG,PSHI,PSHIT,PSIX,PSL,PSLEN
+3 KILL PSLO,PSMARG,PSQ,PSQN,PSQNUM,PSQP,PSTXT,PSTYP,PSWRAP,X,Y
+4 QUIT
+5 ;
SEARCH KILL DIR,DUOUT,DTOUT,PSCH,PSIX,PID,^TMP("PSOD",$JOB)
+1 WRITE !!!!!,"If you do not know the Sequence Number, you may search by any or all of the",!,"following fields: "
+2 WRITE !!?5,"QUESTIONNAIRE",!?5,"DRUG",!?5,"PROVIDER",!!?5,"Type '^' to exit.",!
+3 SET PSFLAG=0
+4 FOR FLD=1,2,4
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
SET DIR(0)="50.0731,"_FLD_"O"
DO ASK
+5 if 'PSFLAG
QUIT
+6 SET IXS=""
+7 FOR FLD=1,2,4
IF $DATA(PSCH(FLD))
IF PSCH(FLD)
SET IXS=$SELECT(FLD=1:"Q",FLD=2:"D",1:"P")_IXS
+8 IF $LENGTH(IXS)>1
SET PSEED=$EXTRACT(IXS)
FOR N=0:0
SET IX=PSEED
DO GETIXN
SET N=$ORDER(^PS(50.0731,PSEED,PSCH(IXN),N))
if 'N
QUIT
SET PSHIT=1
DO GETN
IF PSHIT
SET ^TMP("PSOD",$JOB,N)=""
+9 IF $LENGTH(IXS)=1
SET IX=IXS
DO GETIXN
FOR N=0:0
SET N=$ORDER(^PS(50.0731,IXS,PSCH(IXN),N))
if 'N
QUIT
SET ^TMP("PSOD",$JOB,N)=""
+10 IF '$DATA(^TMP("PSOD",$JOB))
WRITE !!?5,"No Matches Found!!!",!!
QUIT
+11 IF '$ORDER(^TMP("PSOD",$JOB,$ORDER(^TMP("PSOD",$JOB,0))))
SET PSA=$ORDER(^TMP("PSOD",$JOB,0))
WRITE !!
QUIT
+12 SET PSDPOP=0
CHOICES WRITE !!?2,"CHOOSE FROM...",!!
+1 SET DIC="^PS(50.0731,"
SET DR="1:9"
SET DIQ="PID"
SET DIQ(0)="E"
+2 SET PSL=$SELECT($DATA(IOSL):IOSL-3,1:21)
SET (DX,DY)=0
XECUTE ^%ZOSF("XY")
+3 FOR N=0:0
SET N=$ORDER(^TMP("PSOD",$JOB,N))
if 'N
QUIT
DO DISPLAY
if PSDPOP
QUIT
+4 KILL DIC,DIQ
+5 SET PSA=0
+6 QUIT
ASK KILL DA
+1 DO ^DIR
KILL DIR
+2 SET PSCH(FLD)=+Y
SET PSFLAG=PSFLAG+Y
+3 QUIT
GETN FOR I=2:1:$LENGTH(IXS)
SET IX=$EXTRACT(IXS,I)
DO GETIXN
SET PSHIT=PSHIT*$DATA(^PS(50.0731,IX,PSCH(IXN),N))
+1 QUIT
GETIXN SET IXN=$SELECT(IX="Q":1,IX="D":2,1:4)
+1 QUIT
DISPLAY IF $Y
IF $Y>PSL
SET (DX,DY)=0
XECUTE ^%ZOSF("XY")
SET DIR(0)="E"
DO ^DIR
WRITE $CHAR(13),$JUSTIFY("",45),$CHAR(13)
IF 'Y
SET PSDPOP=1
QUIT
+1 SET (PSQNUM,DA)=N
SET PSQ=""
+2 DO EN^DIQ1
+3 FOR ID=.01:0
SET ID=$ORDER(PID(50.0731,DA,ID))
if 'ID
QUIT
SET PSQ=PSQ_PID(50.0731,DA,ID,"E")_$SELECT($LENGTH(PID(50.0731,DA,ID,"E")):"/",1:"")
+4 DO WRAP
+5 QUIT
WRAP ;Enter here from PSODACT,PSODLKP,PSODEDT to format Question
+1 ;Needs PSQ=text, PSQNUM=question number
+2 NEW I,K
+3 SET PSTXT=$PIECE(PSQ,"^")
WRITE !,PSQNUM,"."
+4 SET PSWRAP=1
SET PSMARG=$SELECT('$GET(PSORM):80,$DATA(IOM):IOM,1:80)-5
W1 if $LENGTH(PSTXT)<PSMARG
SET PSWRAP(PSWRAP)=PSTXT
IF $LENGTH(PSTXT)'<PSMARG
FOR I=PSMARG:-1:0
IF $EXTRACT(PSTXT,I)?1P
SET PSWRAP(PSWRAP)=$EXTRACT(PSTXT,1,I)
SET PSTXT=$EXTRACT(PSTXT,I+1,999)
SET PSWRAP=PSWRAP+1
GOTO W1
+1 FOR K=1:1:PSWRAP
WRITE ?($LENGTH(PSQNUM)+2),PSWRAP(K),!
+2 QUIT
QUES2 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 carriage return to bypass."
+4 WRITE !?5,"Enter '^' to exit."
+5 DO WRAP
+6 QUIT
