PSODEDT.m

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

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