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 ---[H[J[2J[HPXBGPL2 3571 printed Oct 16, 2024@18:27:20 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
