PXBPL ;ISL/JVS - ADD DIAGNOSIS TO PROBLEM LIST ;17 Jul 2013 11:21 AM
;;1.0;PCE PATIENT CARE ENCOUNTER;**11,94,115,130,168,199**;Aug 12, 1996;Build 51
;
;
;
W !,"THIS IS NOT AN ENTRY POINT" Q
SET ;--SETUP AND NEW VARIABLES
N OK,PXBPL,PXPRVLIN,FLAG,DATA,ICDCODE
S PXPRVLIN=18 D WIN17^PXBCC(PXBCNT)
I '$G(NOPLLIST) Q
PRMPT ;--Ask if you want to put entries in PL
D LOC^PXBCC(17,0) 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 S PXPRVLIN=PXPRVLIN+2 W !,"Select 1 or several Diagnoses (e.g. 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 wish to add to the PROBLEM LIST." S PXPRVLIN=PXPRVLIN+1 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
..I PXBCNT>10 D DPOV4^PXBDPOV(PXBSAM(PXBPIECE,"LINE"))
..S FLAG=1
..D REVPOV^PXBPPOV(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 S PXPRVLIN=PXPRVLIN+1 G SELECT
PRV ;--Ask for provider
I '$G(FLAG) Q
S FROM="PL" K PXBCNT D PRV^PXBGPRV(PXBVST,,,,.PXBCNT)
N PXBLANKS S $P(PXBLANKS," ",65)=""
D LOC^PXBCC(1,10) W PXBLANKS D LOC^PXBCC(PXPRVLIN,0)
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 diagnoses
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^CV^SHAD"
..F PXII=1:1:8 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
...S PXVDATE=$$CSDATE^PXDXUTL(PXBVST) ; $P(+^AUPNVSIT(PXBVST,0),".",1)
...KILL LEXS D EN^LEXCODE(ICDCODE,PXVDATE)
...S PXACSREC=$$ACTDT^PXDXUTL(PXVDATE),PXACSID=$P(PXACSREC,U,1)
...I $G(LEXS(PXACSID,0))>0 S PXBPL("LEXICON")=$P($G(LEXS(PXACSID,1)),"^",1)
..S PXBPL("DX_DATE_OF_INTEREST")=$$CSDATE^PXDXUTL(PXBVST)
..D CREATE^GMPLUTL(.PXBPL,.PXBRES)
..D PR
K NOPLLIST,PXVDATE,PXACSREC,PXACSID
Q
SEND ;--Entry point to send data to problem list
N PXBPL,OK,ICDCODE,PXVDATE,PXACSREC,PXACSID
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^CV^SHAD"
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
.S PXVDATE=$$CSDATE^PXDXUTL(PXBVST) ; $P(+^AUPNVSIT(PXBVST,0),".",1)
.KILL LEXS D EN^LEXCODE(ICDCODE,PXVDATE)
.S PXACSREC=$$ACTDT^PXDXUTL(PXVDATE),PXACSID=$P(PXACSREC,U,1)
.I $G(LEXS(PXACSID,0))>0 S PXBPL("LEXICON")=$P($G(LEXS(PXACSID,1)),"^",1)
S PXBPL("DX_DATE_OF_INTEREST")=$$CSDATE^PXDXUTL(PXBVST)
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
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPL 4863 printed Apr 09, 2024@21:33:02 Page 2
PXBPL ;ISL/JVS - ADD DIAGNOSIS TO PROBLEM LIST ;17 Jul 2013 11:21 AM
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,94,115,130,168,199**;Aug 12, 1996;Build 51
+2 ;
+3 ;
+4 ;
+5 WRITE !,"THIS IS NOT AN ENTRY POINT"
QUIT
SET ;--SETUP AND NEW VARIABLES
+1 NEW OK,PXBPL,PXPRVLIN,FLAG,DATA,ICDCODE
+2 SET PXPRVLIN=18
DO WIN17^PXBCC(PXBCNT)
+3 IF '$GET(NOPLLIST)
QUIT
PRMPT ;--Ask if you want to put entries in PL
+1 DO LOC^PXBCC(17,0)
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
SET PXPRVLIN=PXPRVLIN+2
WRITE !,"Select 1 or several Diagnoses (e.g. 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 wish to add to the PROBLEM LIST."
SET PXPRVLIN=PXPRVLIN+1
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 IF PXBCNT>10
DO DPOV4^PXBDPOV(PXBSAM(PXBPIECE,"LINE"))
+25 SET FLAG=1
+26 DO REVPOV^PXBPPOV(PXBPIECE)
End DoDot:2
End DoDot:1
+27 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
SET PXPRVLIN=PXPRVLIN+1
GOTO SELECT
PRV ;--Ask for provider
+1 IF '$GET(FLAG)
QUIT
+2 SET FROM="PL"
KILL PXBCNT
DO PRV^PXBGPRV(PXBVST,,,,.PXBCNT)
+3 NEW PXBLANKS
SET $PIECE(PXBLANKS," ",65)=""
+4 DO LOC^PXBCC(1,10)
WRITE PXBLANKS
DO LOC^PXBCC(PXPRVLIN,0)
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 diagnoses
+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^CV^SHAD"
+12 FOR PXII=1:1:8
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 ; $P(+^AUPNVSIT(PXBVST,0),".",1)
SET PXVDATE=$$CSDATE^PXDXUTL(PXBVST)
+18 KILL LEXS
DO EN^LEXCODE(ICDCODE,PXVDATE)
+19 SET PXACSREC=$$ACTDT^PXDXUTL(PXVDATE)
SET PXACSID=$PIECE(PXACSREC,U,1)
+20 IF $GET(LEXS(PXACSID,0))>0
SET PXBPL("LEXICON")=$PIECE($GET(LEXS(PXACSID,1)),"^",1)
End DoDot:3
+21 SET PXBPL("DX_DATE_OF_INTEREST")=$$CSDATE^PXDXUTL(PXBVST)
+22 DO CREATE^GMPLUTL(.PXBPL,.PXBRES)
+23 DO PR
End DoDot:2
End DoDot:1
+24 KILL NOPLLIST,PXVDATE,PXACSREC,PXACSID
+25 QUIT
SEND ;--Entry point to send data to problem list
+1 NEW PXBPL,OK,ICDCODE,PXVDATE,PXACSREC,PXACSID
+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^CV^SHAD"
+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 ; $P(+^AUPNVSIT(PXBVST,0),".",1)
SET PXVDATE=$$CSDATE^PXDXUTL(PXBVST)
+17 KILL LEXS
DO EN^LEXCODE(ICDCODE,PXVDATE)
+18 SET PXACSREC=$$ACTDT^PXDXUTL(PXVDATE)
SET PXACSID=$PIECE(PXACSREC,U,1)
+19 IF $GET(LEXS(PXACSID,0))>0
SET PXBPL("LEXICON")=$PIECE($GET(LEXS(PXACSID,1)),"^",1)
End DoDot:1
+20 SET PXBPL("DX_DATE_OF_INTEREST")=$$CSDATE^PXDXUTL(PXBVST)
+21 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
