PXBGPOV4.m

PXBGPOV4 ;ISL/JVS - DOUBLE ?? GATHERING OF FORM DIAGNOSES ;4/28/97  09:07

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,28**;Aug 12, 1996

 ;

 ;

 ;

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

 ;  

 ;

DOUBLE1(FROM) ;--Entry point

 ;

NEW ;

 ;

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

 N TOTAL,PRV,CNT,PXBPMT,CODE,SUB2

 ;---SETUP VARIABLES

 S BACK="",INDEX=""

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

 ;

START1 ;--RECYCLE POINT

 S TITLE="- - F O R M    D I A G N O S I S - -"

 ;

 D GETLST^IBDF18A(CLINIC,$P($T(POV^PXBAICS),";;",2),"PXBPMT")

ME ;

 ;--------TEST PURPOSES-------

 ;S PXBPMT(0)=4

 ;S PXBPMT(1)="^TEST"

 ;S PXBPMT(2)="309.0^TEST 1"

 ;S PXBPMT(3)="295.12^TEST 2"

 ;S PXBPMT(4)="V62.2^TEST 3"

 ;---------------------

 S TOTAL=PXBPMT(0)

 I PXBPMT(0)>0 D

 .S (SUB,CNT)=0 F  S SUB=$O(PXBPMT(SUB)) Q:SUB=""  D

 ..Q:$P(PXBPMT(SUB),"^",1)=""

 ..S CODE=$P(PXBPMT(SUB),"^",1)

 ..S Y=$O(^ICD9("AB",CODE_" ",0)) Q:Y=""

 ..I $P($G(^ICD9(Y,0)),"^",9)=1 Q

 ..I $P(^(0),"^",11)'=""&(IDATE>($P(^(0),"^",11))) Q

 ..S NAME=$P(PXBPMT(SUB),"^",2)

 ..S CNT=CNT+1

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

 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,2)=NAME

 I $D(CNT) S TOTAL=CNT

 ;

 ;

 ;--DISPLAY IF NO MATCH FOUND

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

 .D LOC W !

 .S RESULTS="NO DIAGNOSIS BLOCKS EXIST FOR AN ENCOUNTER FORM" W !!!,?(IOM-$L(RESULTS))\2,RESULTS D HELP1^PXBUTL1("CON") R OK:DTIME

 I TOTAL=0 Q TOTAL

 ;

 ;

 ;----DISPLAY LIST TO THE SCREEN

 S HEADING="W !,""ITEM"",?6,""CODE"",?13,""DESCRIPTION   "",IOINHI,TOTAL,"" ENTRIES"",IOINLOW"

LIST ;-DISPLAY LIST TO THE SCREEN

 D LOC W !

 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 CODE=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))

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

 .W !,SUB,?6,CODE,?13,NAME

 ;

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

 I TOTAL=1 G PRMPT2

 ;

PRMPT ;---WRITE PROMPT HERE

 D WIN17^PXBCC(PXBCNT)

 D LOC^PXBCC(15,1)

 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("?")="Enter ITEM 'No' to select , '^' to quit"

 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="^"

 I $G(DIRUT) K DIRUT S VAL="^P" G EXITNEW

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

 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 !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$L(TITLE))\2,IOINHI,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 D

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

 Q

PRMPT2 ;-----Yes and No prompt if onlyi 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

PXBGPOV4  ;ISL/JVS - DOUBLE ?? GATHERING OF FORM DIAGNOSES ;4/28/97  09:07

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,28**;Aug 12, 1996

 +2       ;

 +3       ;

 +4       ;

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

           QUIT 

 +6       ;  

 +7       ;

DOUBLE1(FROM) ;--Entry point

 +1       ;

NEW       ;

 +1       ;

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

 +3        NEW TOTAL,PRV,CNT,PXBPMT,CODE,SUB2

 +4       ;---SETUP VARIABLES

 +5        SET BACK=""

           SET INDEX=""

 +6        SET START=DATA

           SET SUB=0

           SET SUB2=0

 +7       ;

START1    ;--RECYCLE POINT

 +1        SET TITLE="- - F O R M    D I A G N O S I S - -"

 +2       ;

 +3        DO GETLST^IBDF18A(CLINIC,$PIECE($TEXT(POV^PXBAICS),";;",2),"PXBPMT")

ME        ;

 +1       ;--------TEST PURPOSES-------

 +2       ;S PXBPMT(0)=4

 +3       ;S PXBPMT(1)="^TEST"

 +4       ;S PXBPMT(2)="309.0^TEST 1"

 +5       ;S PXBPMT(3)="295.12^TEST 2"

 +6       ;S PXBPMT(4)="V62.2^TEST 3"

 +7       ;---------------------

 +8        SET TOTAL=PXBPMT(0)

 +9        IF PXBPMT(0)>0

               Begin DoDot:1

 +10               SET (SUB,CNT)=0

                   FOR 

                       SET SUB=$ORDER(PXBPMT(SUB))

                       IF SUB=""

                           QUIT 

                       Begin DoDot:2

 +11                       IF $PIECE(PXBPMT(SUB),"^",1)=""

                               QUIT 

 +12                       SET CODE=$PIECE(PXBPMT(SUB),"^",1)

 +13                       SET Y=$ORDER(^ICD9("AB",CODE_" ",0))

                           IF Y=""

                               QUIT 

 +14                       IF $PIECE($GET(^ICD9(Y,0)),"^",9)=1

                               QUIT 

 +15                       IF $PIECE(^(0),"^",11)'=""&(IDATE>($PIECE(^(0),"^",11)))

                               QUIT 

 +16                       SET NAME=$PIECE(PXBPMT(SUB),"^",2)

 +17                       SET CNT=CNT+1

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

 +19                       SET ^TMP("PXBTOTAL",$JOB,"DILIST","ID",CNT,2)=NAME

                       End DoDot:2

               End DoDot:1

 +20       IF $DATA(CNT)

               SET TOTAL=CNT

 +21      ;

 +22      ;

 +23      ;--DISPLAY IF NO MATCH FOUND

 +24       IF TOTAL=0

               WRITE IOCUU,IOCUU,!,IOELEOL

               Begin DoDot:1

 +25               DO LOC

                   WRITE !

 +26               SET RESULTS="NO DIAGNOSIS BLOCKS EXIST FOR AN ENCOUNTER FORM"

                   WRITE !!!,?(IOM-$LENGTH(RESULTS))\2,RESULTS

                   DO HELP1^PXBUTL1("CON")

                   READ OK:DTIME

               End DoDot:1

 +27       IF TOTAL=0

               QUIT TOTAL

 +28      ;

 +29      ;

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

 +31       SET HEADING="W !,""ITEM"",?6,""CODE"",?13,""DESCRIPTION   "",IOINHI,TOTAL,"" ENTRIES"",IOINLOW"

LIST      ;-DISPLAY LIST TO THE SCREEN

 +1        DO LOC

           WRITE !

 +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 CODE=$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,.01))

 +6                SET NAME=$GET(^TMP("PXBTOTAL",$JOB,"DILIST","ID",SUB,2))

 +7                WRITE !,SUB,?6,CODE,?13,NAME

               End DoDot:1

 +8       ;

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

 +10       IF TOTAL=1

               GOTO PRMPT2

 +11      ;

PRMPT     ;---WRITE PROMPT HERE

 +1        DO WIN17^PXBCC(PXBCNT)

 +2        DO LOC^PXBCC(15,1)

 +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("?")="Enter ITEM 'No' to select , '^' to quit"

 +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="^"

 +13       IF $GET(DIRUT)

               KILL DIRUT

               SET VAL="^P"

               GOTO EXITNEW

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

 +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 !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$LENGTH(TITLE))\2,IOINHI,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

           Begin DoDot:1

           End DoDot:1

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

 +3        QUIT 

PRMPT2    ;-----Yes and No prompt if onlyi 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