Routine: PXBPL

PXBPL ;ISL/JVS - ADD DIAGNOSIS TO PROBLEM LIST ; 3/27/02 4:48pm

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

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

SET ;--SETUP AND NEW VARIABLES

 N OK,PXBPL,FLAG,DATA,ICDCODE

 D WIN17^PXBCC(PXBCNT)

 I '$G(NOPLLIST) Q

PRMPT ;--Ask if you want to put entries in PL

 S DIR(0)="Y,A,O"

 S DIR("B")="NO"

 I PXBCNT'>1 S DIR("A")="Would you like to add this Diagnosis to the Problem List? "

 I PXBCNT>1 S DIR("A")="Would you like to add any Diagnoses to the Problem List? "

 D ^DIR K DIR

 I Y=0!(Y="^")!(Y="") Q

SELECT ;--Select entries for PL

W !

 I PXBCNT'>1 S OK=1

 I PXBCNT>1 W !,"Select 1 or several Diagnoses (eg 1,3,4,7,3-6,2-5): " R OK:DTIME

 I OK?1.N1"E".NAP S OK=" "_OK

 I OK?24.N S OK=$E(OK,1,24)

 I OK["-" D

 .N PIECE,PXBI,PXBJ,PXBK

 .S PIECE="" F PXBI=1:1:$L(OK,",") S PIECE=$P(OK,",",PXBI) I PIECE["-" D

 ..S PXBJ=0 F PXBJ=$P(PIECE,"-",1):1:$P(PIECE,"-",2) S PXBK=","_PXBJ,OK=OK_PXBK

 S PXBLEN=0

 I OK["?" W !,"Enter the ITEM numbers of the entries you whish to add to the PROBLEM LIST." G SELECT

 ;----SPACE BAR---------

 I OK'=" ",OK'["^",OK'="" S ^DISV(DUZ,"PXBPL-2")=OK

 I OK=" ",$D(^DISV(DUZ,"PXBPL-2")) S OK=^DISV(DUZ,"PXBPL-2") W OK

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

 S PXBLEN=$L(OK,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(OK,",",PXI) D

 .Q:PXBPIECE=""

 .I $D(PXBSAM(PXBPIECE)) D

 ..S FLAG=1

 ..D REVPOV^PXBCC(PXBPIECE)

 I '$G(FLAG) S DIR(0)="Y^AO",DIR("B")="NO",DIR("A")="INVALID entry. Would you like to try again" D ^DIR K DIR I Y=1 K Y G SELECT

PRV ;--Ask for provider

 I '$G(FLAG) Q

 S FROM="PL" D PRV^PXBGPRV(PXBVST)

R K ERROR S FROM="PL" D PRV^PXBPPRV G:$G(ERROR) R W IOEDEOP

 I DATA["^P" D LOC^PXBCC(3,0),EN0^PXBDPRV,LOC^PXBCC(15,0) G PRV

 D POV^PXBGPOV(PXBVST)

LOOP ;--Loop through diagnosis

 S PXBLEN=$L(OK,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(OK,",",PXI) D

 .I PXBPIECE="" Q

 .I $D(PXBSAM(PXBPIECE)) D

 ..S PXBPL("PATIENT")=PATIENT

 ..S PXBPL("NARRATIVE")=$P($G(PXBSAM(PXBPIECE)),"^",3)

 ..S PXBPL("PROVIDER")=$P(REQI,"^",1)

 ..S PXBPL("DIAGNOSIS")=+^AUPNVPOV($O(PXBSKY(PXBPIECE,0)),0)

 ..S PXBPL("LOCATION")=$P(^AUPNVSIT(PXBVST,0),"^",22)

 ..;PRH - PX*1*115 - Set up Service Conditions

 ..N PXSCSTR,PXII,PXTYP

 ..S PXSCSTR="SC^AO^IR^EC^MST^HNC"

 ..F PXII=1:1:6 D

 ...S PXTYP=$P(PXSCSTR,"^",PXII)

 ...S PXBPL(PXTYP)=$P($G(^AUPNVSIT(PXBVST,800)),"^",PXII)

 ..S ICDCODE="",ICDCODE=$P($G(PXBSAM(PXBPIECE)),"^",1)

 ..I ICDCODE'="" D  ; Get Lexicon entry for ICD Code

 ...KILL LEXS D EN^LEXCODE(ICDCODE)

 ...I $G(LEXS("ICD",0))>0 S PXBPL("LEXICON")=$P($G(LEXS("ICD",1)),"^",1)

 ..D CREATE^GMPLUTL(.PXBPL,.PXBRES)

 ..D PR

 K NOPLLIST

SEND ;--Entry point to send data to problem list

 N PXBPL,OK,ICDCODE

 I '$D(IORVON) D TERM^PXBCC

 S PXBPL("PATIENT")=PATIENT

 S PXBPL("NARRATIVE")=PXBSAM($O(PXBKY($P($P(REQE,"^",5)," ",1),0)),"LNARR")

 S PXBPL("PROVIDER")=$P(REQI,"^",1)

 S PXBPL("DIAGNOSIS")=$P(REQI,"^",5)

 S PXBPL("LOCATION")=$P(^AUPNVSIT(PXBVST,0),"^",22)

 ;PRH - PX*1*115 - Set up Service Conditions

 N PXSCSTR,PXII,PXTYP

 S PXSCSTR="SC^AO^IR^EC^MST^HNC"

 F PXII=1:1:6 D

 . S PXTYP=$P(PXSCSTR,"^",PXII)

 . S PXBPL(PXTYP)=$P($G(^AUPNVSIT(PXBVST,800)),"^",PXII)

 S ICDCODE="",ICDCODE=$P($G(PXBSAM($O(PXBKY($P($P(REQE,"^",5)," ",1),0)))),"^",1)

 I ICDCODE'="" D  ; Get Lexicon entry for ICD Code

 .KILL LEXS D EN^LEXCODE(ICDCODE)

 .I $G(LEXS("ICD",0))>0 S PXBPL("LEXICON")=$P($G(LEXS("ICD",1)),"^",1)

 D CREATE^GMPLUTL(.PXBPL,.PXBRES)

PR ;

 I PXBRES<0 D  Q  ;'Q'uit added for PX*1*115

 .W !,IORVON,"--WARNING-Problem NOT Created because: ",PXBRES(0),IORVOFF

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

 ;PX*1*115 - Add Problem File Pointer to V POV file

 I PXBRES>0 D

 . N DA,DIE,DR,PXBPLARR,PXBPLERR,PXBPLPOV

 . S DA=$O(PXBSKY(PXBPIECE,0))

 . S PXBPLPOV=9000010.07

 . K PXBPLARR,PXBPLERR

 . D GETS^DIQ(PXBPLPOV,(DA_","),.16,"I","PXBPLARR","PXBPLERR")

 . Q:$D(PXBPLERR)

 . I $L($G(PXBPLARR(PXBPLPOV,(DA_","),.16,"I"))) Q

. ;

 . S DIE="^AUPNVPOV(",DR=".16////"_PXBRES

 . D ^DIE

PXBPL     ;ISL/JVS - ADD DIAGNOSIS TO PROBLEM LIST ; 3/27/02 4:48pm

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

 +2       ;

 +3       ;

 +4       ;

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

           QUIT

SET       ;--SETUP AND NEW VARIABLES

 +1        NEW OK,PXBPL,FLAG,DATA,ICDCODE

 +2        DO WIN17^PXBCC(PXBCNT)

 +3        IF '$GET(NOPLLIST)

               QUIT

PRMPT     ;--Ask if you want to put entries in PL

 +1        SET DIR(0)="Y,A,O"

 +2        SET DIR("B")="NO"

 +3        IF PXBCNT'>1

               SET DIR("A")="Would you like to add this Diagnosis to the Problem List? "

 +4        IF PXBCNT>1

               SET DIR("A")="Would you like to add any Diagnoses to the Problem List? "

 +5        DO ^DIR

           KILL DIR

 +6        IF Y=0!(Y="^")!(Y="")

               QUIT

SELECT    ;--Select entries for PL

 +1        WRITE !

 +2        IF PXBCNT'>1

               SET OK=1

 +3        IF PXBCNT>1

               WRITE !,"Select 1 or several Diagnoses (eg 1,3,4,7,3-6,2-5): "

               READ OK:DTIME

 +4        IF OK?1.N1"E".NAP

               SET OK=" "_OK

 +5        IF OK?24.N

               SET OK=$EXTRACT(OK,1,24)

 +6       ;

 +7       ;

 +8        IF OK["-"

               Begin DoDot:1

 +9                NEW PIECE,PXBI,PXBJ,PXBK

 +10               SET PIECE=""

                   FOR PXBI=1:1:$LENGTH(OK,",")

                       SET PIECE=$PIECE(OK,",",PXBI)

                       IF PIECE["-"

                           Begin DoDot:2

 +11                           SET PXBJ=0

                               FOR PXBJ=$PIECE(PIECE,"-",1):1:$PIECE(PIECE,"-",2)

                                   SET PXBK=","_PXBJ

                                   SET OK=OK_PXBK

                           End DoDot:2

               End DoDot:1

 +12      ;

 +13      ;

 +14      ;

 +15       SET PXBLEN=0

 +16       IF OK["?"

               WRITE !,"Enter the ITEM numbers of the entries you whish to add to the PROBLEM LIST."

               GOTO SELECT

 +17      ;----SPACE BAR---------

 +18       IF OK'=" "

               IF OK'["^"

                   IF OK'=""

                       SET ^DISV(DUZ,"PXBPL-2")=OK

 +19       IF OK=" "

               IF $DATA(^DISV(DUZ,"PXBPL-2"))

                   SET OK=^DISV(DUZ,"PXBPL-2")

                   WRITE OK

 +20      ;-----------------------

 +21       SET PXBLEN=$LENGTH(OK,",")

           FOR PXI=1:1:PXBLEN

               SET PXBPIECE=$PIECE(OK,",",PXI)

               Begin DoDot:1

 +22               IF PXBPIECE=""

                       QUIT

 +23               IF $DATA(PXBSAM(PXBPIECE))

                       Begin DoDot:2

 +24                       SET FLAG=1

 +25                       DO REVPOV^PXBCC(PXBPIECE)

                       End DoDot:2

               End DoDot:1

 +26       IF '$GET(FLAG)

               SET DIR(0)="Y^AO"

               SET DIR("B")="NO"

               SET DIR("A")="INVALID entry. Would you like to try again"

               DO ^DIR

               KILL DIR

               IF Y=1

                   KILL Y

                   GOTO SELECT

PRV       ;--Ask for provider

 +1        IF '$GET(FLAG)

               QUIT

 +2        SET FROM="PL"

           DO PRV^PXBGPRV(PXBVST)

R          KILL ERROR

           SET FROM="PL"

           DO PRV^PXBPPRV

           IF $GET(ERROR)

               GOTO R

           WRITE IOEDEOP

 +1        IF DATA["^P"

               DO LOC^PXBCC(3,0)

               DO EN0^PXBDPRV

               DO LOC^PXBCC(15,0)

               GOTO PRV

 +2        DO POV^PXBGPOV(PXBVST)

LOOP      ;--Loop through diagnosis

 +1        SET PXBLEN=$LENGTH(OK,",")

           FOR PXI=1:1:PXBLEN

               SET PXBPIECE=$PIECE(OK,",",PXI)

               Begin DoDot:1

 +2                IF PXBPIECE=""

                       QUIT

 +3                IF $DATA(PXBSAM(PXBPIECE))

                       Begin DoDot:2

 +4                        SET PXBPL("PATIENT")=PATIENT

 +5                        SET PXBPL("NARRATIVE")=$PIECE($GET(PXBSAM(PXBPIECE)),"^",3)

 +6                        SET PXBPL("PROVIDER")=$PIECE(REQI,"^",1)

 +7                        SET PXBPL("DIAGNOSIS")=+^AUPNVPOV($ORDER(PXBSKY(PXBPIECE,0)),0)

 +8                        SET PXBPL("LOCATION")=$PIECE(^AUPNVSIT(PXBVST,0),"^",22)

 +9       ;PRH - PX*1*115 - Set up Service Conditions

 +10                       NEW PXSCSTR,PXII,PXTYP

 +11                       SET PXSCSTR="SC^AO^IR^EC^MST^HNC"

 +12                       FOR PXII=1:1:6

                               Begin DoDot:3

 +13                               SET PXTYP=$PIECE(PXSCSTR,"^",PXII)

 +14                               SET PXBPL(PXTYP)=$PIECE($GET(^AUPNVSIT(PXBVST,800)),"^",PXII)

                               End DoDot:3

 +15                       SET ICDCODE=""

                           SET ICDCODE=$PIECE($GET(PXBSAM(PXBPIECE)),"^",1)

 +16      ; Get Lexicon entry for ICD Code

                           IF ICDCODE'=""

                               Begin DoDot:3

 +17                               KILL LEXS

                                   DO EN^LEXCODE(ICDCODE)

 +18                               IF $GET(LEXS("ICD",0))>0

                                       SET PXBPL("LEXICON")=$PIECE($GET(LEXS("ICD",1)),"^",1)

                               End DoDot:3

 +19                       DO CREATE^GMPLUTL(.PXBPL,.PXBRES)

 +20                       DO PR

                       End DoDot:2

               End DoDot:1

 +21       KILL NOPLLIST

 +22       QUIT

SEND      ;--Entry point to send data to problem list

 +1        NEW PXBPL,OK,ICDCODE

 +2        IF '$DATA(IORVON)

               DO TERM^PXBCC

 +3        SET PXBPL("PATIENT")=PATIENT

 +4        SET PXBPL("NARRATIVE")=PXBSAM($ORDER(PXBKY($PIECE($PIECE(REQE,"^",5)," ",1),0)),"LNARR")

 +5        SET PXBPL("PROVIDER")=$PIECE(REQI,"^",1)

 +6        SET PXBPL("DIAGNOSIS")=$PIECE(REQI,"^",5)

 +7        SET PXBPL("LOCATION")=$PIECE(^AUPNVSIT(PXBVST,0),"^",22)

 +8       ;PRH - PX*1*115 - Set up Service Conditions

 +9        NEW PXSCSTR,PXII,PXTYP

 +10       SET PXSCSTR="SC^AO^IR^EC^MST^HNC"

 +11       FOR PXII=1:1:6

               Begin DoDot:1

 +12               SET PXTYP=$PIECE(PXSCSTR,"^",PXII)

 +13               SET PXBPL(PXTYP)=$PIECE($GET(^AUPNVSIT(PXBVST,800)),"^",PXII)

               End DoDot:1

 +14       SET ICDCODE=""

           SET ICDCODE=$PIECE($GET(PXBSAM($ORDER(PXBKY($PIECE($PIECE(REQE,"^",5)," ",1),0)))),"^",1)

 +15      ; Get Lexicon entry for ICD Code

           IF ICDCODE'=""

               Begin DoDot:1

 +16               KILL LEXS

                   DO EN^LEXCODE(ICDCODE)

 +17               IF $GET(LEXS("ICD",0))>0

                       SET PXBPL("LEXICON")=$PIECE($GET(LEXS("ICD",1)),"^",1)

               End DoDot:1

 +18       DO CREATE^GMPLUTL(.PXBPL,.PXBRES)

PR        ;

 +1       ;'Q'uit added for PX*1*115

           IF PXBRES<0

               Begin DoDot:1

 +2                WRITE !,IORVON,"--WARNING-Problem NOT Created because: ",PXBRES(0),IORVOFF

 +3                DO HELP1^PXBUTL1("CON")

                   READ OK:DTIME

               End DoDot:1

               QUIT

 +4       ;

 +5       ;PX*1*115 - Add Problem File Pointer to V POV file

 +6        IF PXBRES>0

               Begin DoDot:1

 +7                NEW DA,DIE,DR,PXBPLARR,PXBPLERR,PXBPLPOV

 +8                SET DA=$ORDER(PXBSKY(PXBPIECE,0))

 +9                SET PXBPLPOV=9000010.07

 +10               KILL PXBPLARR,PXBPLERR

 +11               DO GETS^DIQ(PXBPLPOV,(DA_","),.16,"I","PXBPLARR","PXBPLERR")

 +12               IF $DATA(PXBPLERR)

                       QUIT

 +13               IF $LENGTH($GET(PXBPLARR(PXBPLPOV,(DA_","),.16,"I")))

                       QUIT

 +14      ;

 +15               SET DIE="^AUPNVPOV("

                   SET DR=".16////"_PXBRES

 +16               DO ^DIE

               End DoDot:1

 +17      ;

 +18       QUIT

PXBPL.m