PXBGPL2.m

PXBGPL2 ;ISL/JVS - DOUBLE ?? GATHERING OF PATIENT PROBLEM LIST;3/8/96  11:33 ;11/5/96  14:18

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,199**;Aug 12, 1996;Build 51

 ;

 W !,"THIS IS NOT AN ENTRY POINT" Q

 ;

 ;

DOUBLE1(FROM) ;--Entry point

 ;

NEW ;

 ;

 S PNAME=NAME

 N FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE

 N TOTAL,POV,CNT,PXBPMT,SUB2

 ;---SETUP VARIABLES

 S BACK="",INDEX=""

 S START=DATA,SUB=0,SUB2=0

 ;

START1 ;--RECYCLE POINT

 S TITLE="PATIENT PROBLEM LIST"

 ;

 D PL^PXBGPL(PATIENT)

 ;

 I '$D(PXBPMT) S TOTAL=0

 I $D(PXBPMT) D

 .S (POV,CNT)="" F  S POV=$O(PXBPMT("PL",POV)) Q:POV=""  S CNT=CNT+1 D

 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,.01)=POV

 I $D(CNT) S TOTAL=CNT

 ;

 ;--DISPLAY IF NO MATCH FOUND

 I TOTAL=0 W IOCUU,IOCUU,!,IOELEOL D

 .D LOC W !

 .W !!! D HELP^PXBUTL0("PLM")

 .D HELP1^PXBUTL1("CON") R OK:DTIME

 I TOTAL=0 Q TOTAL

 ;

 ;

 ;----DISPLAY LIST TO THE SCREEN

 S HEADING="W !,""ITEM"",?6,""NAME"",?16,""DESCRIPTION "",IOINHI,TOTAL,"" MATCHES"",IOINLOW"

LIST ;-DISPLAY LIST TO THE SCREEN

 D LOC,HEAD

 X HEADING

 S SUB=SUB-1

 S NUM=0 F  S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) S NUM=NUM+1 Q:NUM=11  Q:SUB'>0  S SUB2=SUB2+1 D

 .S NAME=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))

 .W !,SUB,?6,$P(NAME," ",1),?16,$E($P(NAME," ",2,$L(NAME," ")),1,63)

 ;

 ;----If There is only one selection go to proper prompting

 I TOTAL=1 G PRMPT2

 I $G(VALL)=1 G PRMPT3

 ;

PRMPT ;---WRITE PROMPT HERE

 D LOC^PXBCC(15,1)

 D WIN17^PXBCC(PXBCNT)

 W !

 I SUB>0 W !,"Enter '^' to quit"

 E  I TOTAL>10 W !,"               END OF LIST"

 I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "

 E  S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "

 S DIR("?")="^D HELP^PXBUTL0(""PL11"")"

 S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"

 D ^DIR

 I X="",SUB>0 G LIST

 I X="",SUB'>0 S X="^"

VAL ;-----Set the VAL equal to the value

 S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))

EXITNEW ;--EXIT

 K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)

 K TANA,TOTAL

 Q VAL

PRMPT3 ;---WRITE PROMPT HERE

 D LOC^PXBCC(15,1)

 D WIN17^PXBCC(PXBCNT)

 W !!

 D HELP1^PXBUTL1("CON") R OK:DTIME

 I SUB>0 G LIST

 I SUB'>0 S X="^"

VALL ;-----Set the VAL equal to the value

 S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))

EXITNEWW ;--EXIT

 K ^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)

 K TANA,TOTAL

 Q VAL

 Q

 ;

 ;-----------------SUBROUTINES--------------

BACK ;

 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))

 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))

 Q

FORWARD ;

 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))

 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))

 Q

LOC ;--LOCATE CURSOR

 D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR

 W IOEDEOP ;--CLEAR THE PAGE

 Q

HEAD ;--HEAD

 W IOINHI,!,IOCUU,?(IOM-$L(TITLE))\2,TITLE,IOINLOW,IOELEOL

 Q

SUB ;--DISPLAY LIST TO THE SCREEN

 I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!,"     E N D  O F  L I S T" Q

 X HEADING

 S SUB=0,CNT=0 F  S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0  S CNT=CNT+1 D

 .S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,.01))

 .W !,SUB,?6,NAME

 Q

SETUP ;-SETP VARIABLES

 S FILE=200,FIELD=.01

 S HEADING="W !,""ITEM"",?6,""NAME"""

 Q

PRMPT2 ;-----Yes and No prompt if only choice

 D WIN17^PXBCC(PXBCNT)

 D LOC^PXBCC(15,1)

 S DIR("A")="Is this the correct entry "

 S DIR("B")="YES"

 S DIR(0)="Y"

 D ^DIR

 I Y=0 S X="^"

 I Y=1 S X=1

 G VAL

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PXBGPL2   3571     printed  Feb 18, 2025@23:52:55                                                                                                                                                                                                     Page 2

PXBGPL2   ;ISL/JVS - DOUBLE ?? GATHERING OF PATIENT PROBLEM LIST;3/8/96  11:33 ;11/5/96  14:18

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,199**;Aug 12, 1996;Build 51

 +2       ;

 +3        WRITE !,"THIS IS NOT AN ENTRY POINT"

           QUIT 

 +4       ;

 +5       ;

DOUBLE1(FROM) ;--Entry point

 +1       ;

NEW       ;

 +1       ;

 +2        SET PNAME=NAME

 +3        NEW FILE,FIELD,TITLE,HEADING,SUB,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE

 +4        NEW TOTAL,POV,CNT,PXBPMT,SUB2

 +5       ;---SETUP VARIABLES

 +6        SET BACK=""

           SET INDEX=""

 +7        SET START=DATA

           SET SUB=0

           SET SUB2=0

 +8       ;

START1    ;--RECYCLE POINT

 +1        SET TITLE="PATIENT PROBLEM LIST"

 +2       ;

 +3        DO PL^PXBGPL(PATIENT)

 +4       ;

 +5        IF '$DATA(PXBPMT)

               SET TOTAL=0

 +6        IF $DATA(PXBPMT)

               Begin DoDot:1

 +7                SET (POV,CNT)=""

                   FOR 

                       SET POV=$ORDER(PXBPMT("PL",POV))

                       if POV=""

                           QUIT 

                       SET CNT=CNT+1

                       Begin DoDot:2

 +8                        SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",CNT,.01)=POV

                       End DoDot:2

               End DoDot:1

 +9        IF $DATA(CNT)

               SET TOTAL=CNT

 +10      ;

 +11      ;--DISPLAY IF NO MATCH FOUND

 +12       IF TOTAL=0

               WRITE IOCUU,IOCUU,!,IOELEOL

               Begin DoDot:1

 +13               DO LOC

                   WRITE !

 +14               WRITE !!!

                   DO HELP^PXBUTL0("PLM")

 +15               DO HELP1^PXBUTL1("CON")

                   READ OK:DTIME

               End DoDot:1

 +16       IF TOTAL=0

               QUIT TOTAL

 +17      ;

 +18      ;

 +19      ;----DISPLAY LIST TO THE SCREEN

 +20       SET HEADING="W !,""ITEM"",?6,""NAME"",?16,""DESCRIPTION "",IOINHI,TOTAL,"" MATCHES"",IOINLOW"

LIST      ;-DISPLAY LIST TO THE SCREEN

 +1        DO LOC

           DO HEAD

 +2        XECUTE HEADING

 +3        SET SUB=SUB-1

 +4        SET NUM=0

           FOR 

               SET SUB=$ORDER(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB))

               SET NUM=NUM+1

               if NUM=11

                   QUIT 

               if SUB'>0

                   QUIT 

               SET SUB2=SUB2+1

               Begin DoDot:1

 +5                SET NAME=$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,.01))

 +6                WRITE !,SUB,?6,$PIECE(NAME," ",1),?16,$EXTRACT($PIECE(NAME," ",2,$LENGTH(NAME," ")),1,63)

               End DoDot:1

 +7       ;

 +8       ;----If There is only one selection go to proper prompting

 +9        IF TOTAL=1

               GOTO PRMPT2

 +10       IF $GET(VALL)=1

               GOTO PRMPT3

 +11      ;

PRMPT     ;---WRITE PROMPT HERE

 +1        DO LOC^PXBCC(15,1)

 +2        DO WIN17^PXBCC(PXBCNT)

 +3        WRITE !

 +4        IF SUB>0

               WRITE !,"Enter '^' to quit"

 +5       IF '$TEST

               IF TOTAL>10

                   WRITE !,"               END OF LIST"

 +6        IF SUB>0

               SET DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "

 +7       IF '$TEST

               SET DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "

 +8        SET DIR("?")="^D HELP^PXBUTL0(""PL11"")"

 +9        SET DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"

 +10       DO ^DIR

 +11       IF X=""

               IF SUB>0

                   GOTO LIST

 +12       IF X=""

               IF SUB'>0

                   SET X="^"

VAL       ;-----Set the VAL equal to the value

 +1        SET VAL=$GET(^TMP("PXBTOTAL",$JOB,"DILIST",2,X))_"^"_$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,.01))

EXITNEW   ;--EXIT

 +1        KILL DIR,^TMP("PXBTANA",$JOB),^TMP("PXBTOTAL",$JOB)

 +2        KILL TANA,TOTAL

 +3        QUIT VAL

PRMPT3    ;---WRITE PROMPT HERE

 +1        DO LOC^PXBCC(15,1)

 +2        DO WIN17^PXBCC(PXBCNT)

 +3        WRITE !!

 +4        DO HELP1^PXBUTL1("CON")

           READ OK:DTIME

 +5        IF SUB>0

               GOTO LIST

 +6        IF SUB'>0

               SET X="^"

VALL      ;-----Set the VAL equal to the value

 +1        SET VAL=$GET(^TMP("PXBTOTAL",$JOB,"DILIST",2,X))_"^"_$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",X,.01))

EXITNEWW  ;--EXIT

 +1        KILL ^TMP("PXBTANA",$JOB),^TMP("PXBTOTAL",$JOB)

 +2        KILL TANA,TOTAL

 +3        QUIT VAL

 +4        QUIT 

 +5       ;

 +6       ;-----------------SUBROUTINES--------------

BACK      ;

 +1        SET START=$GET(^TMP("PXBTANA",$JOB,"DILIST",1,1))

 +2        SET START("IEN")=$GET(^TMP("PXBTANA",$JOB,"DILIST",2,1))

 +3        QUIT 

FORWARD   ;

 +1        SET START=$GET(^TMP("PXBTANA",$JOB,"DILIST",1,10))

 +2        SET START("IEN")=$GET(^TMP("PXBTANA",$JOB,"DILIST",2,10))

 +3        QUIT 

LOC       ;--LOCATE CURSOR

 +1       ;--LOCATE THE CURSOR

           DO LOC^PXBCC(3,1)

 +2       ;--CLEAR THE PAGE

           WRITE IOEDEOP

 +3        QUIT 

HEAD      ;--HEAD

 +1        WRITE IOINHI,!,IOCUU,?(IOM-$LENGTH(TITLE))\2,TITLE,IOINLOW,IOELEOL

 +2        QUIT 

SUB       ;--DISPLAY LIST TO THE SCREEN

 +1        IF $PIECE(^TMP("PXBTANA",$JOB,"DILIST",0),"^",1)=0

               WRITE !!,"     E N D  O F  L I S T"

               QUIT 

 +2        XECUTE HEADING

 +3        SET SUB=0

           SET CNT=0

           FOR 

               SET SUB=$ORDER(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB))

               if SUB'>0

                   QUIT 

               SET CNT=CNT+1

               Begin DoDot:1

 +4                SET NAME=$GET(^TMP("PXBTANA",$JOB,"DILIST","ID",SUB,.01))

 +5                WRITE !,SUB,?6,NAME

               End DoDot:1

 +6        QUIT 

SETUP     ;-SETP VARIABLES

 +1        SET FILE=200

           SET FIELD=.01

 +2        SET HEADING="W !,""ITEM"",?6,""NAME"""

 +3        QUIT 

PRMPT2    ;-----Yes and No prompt if only choice

 +1        DO WIN17^PXBCC(PXBCNT)

 +2        DO LOC^PXBCC(15,1)

 +3        SET DIR("A")="Is this the correct entry "

 +4        SET DIR("B")="YES"

 +5        SET DIR(0)="Y"

 +6        DO ^DIR

 +7        IF Y=0

               SET X="^"

 +8        IF Y=1

               SET X=1

 +9        GOTO VAL