- PXBPPOV1 ;ISL/JVS,ESW - PROMPT POV ;4/6/05 2:41pm
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112,121,124,199**;Aug 12, 1996;Build 51
- ;
- ;
- ;
- ;
- ;
- ADDM ;--------If Multiple POV entries have been entered.
- ;
- ;
- ;
- N BDATA,OK,PXBLEN,PXDXDATE
- S PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
- D WIN17^PXBCC(PXBCNT)
- S NF=0,PXBLEN=0
- I DATA[",",$E(DATA,1)'["@" S NF=1 D
- .S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
- ..S Y=$$ICDDATA^ICDXCODE("DIAG",PXBPIECE,PXDXDATE,"E")
- ..I $P(Y,U)=-1!($P(Y,U,10)'=1) S BAD($G(PXBPIECE))="" Q
- ..S $P(REQI,"^",5)=+Y
- ..S PXBNPOV(PXBPIECE)=""
- ..;
- ..;--Prompt for Primary or Secondary DIAGNOSIS
- ..; ICD-10 Remediation note: the next two lines display code--code (ex. 369.65--369.65)
- ..; we think this is wrong but do not have specs to fix it.
- ..W !,"For the DIAGNOSIS: ",PXBPIECE,"--"
- ..W $P(Y,U,2),!
- ..D WIN17^PXBCC(PXBCNT)
- ..D PRI^PXBPPOV1
- ..I $D(DIRUT) D RSET^PXBDREQ("POV") Q
- ..D ORD^PXBPPOV1
- ..N PXCEVIEN,PXCEAFTR,PXD
- ..S PXCEVIEN=PXBVST,PXD=$P(REQI,U,5)
- ..D WIN17^PXBCC(PXBCNT),GET800^PXCEC800 ;CI's
- ..S PXBREQ(PXD,"I")=$G(PXCEAFTR(800))
- ..;
- ..D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
- ..D EN1^PXKMAIN
- ..D RSET^PXBDREQ("POV")
- I $G(NF)&($D(BAD)) D Q
- .S (BDATA,EDATA)="" F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
- .W ! D HELP^PXBUTL0("CPTM") W !
- .S DIR(0)="E" D ^DIR K DIR,DIRUT
- .S:Y=1 DATA="^P" S:Y=0!(Y="") DATA="^" K Y
- I $G(NF)&('$D(BAD)) S DATA="^P" Q
- ;
- Q
- ;
- DELM ;--------If Multiple deleting
- N BAD,BDATA,DELM,PXBJ,PXBLEN
- S NF=0,PXBLEN=0 S $P(DELM,"^",3)=1
- I $E(DATA,1)="@" S DATA=$P(DATA,"@",2),NF=1 D
- .S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
- ..I PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1))) S BAD(+$G(PXBPIECE))="" Q
- ..I PXBPIECE'["-" D
- ...I $D(GONE(PXBPIECE)) Q
- ...Q:PXBPIECE'?.N
- ...S $P(REQI,"^",9)=$O(PXBSKY(PXBPIECE,0)) ;-IEN
- ...S X=$P(PXBSAM(PXBPIECE),U,1),Y=$$ICDDATA^ICDXCODE("DIAG",X,PXDXDATE,"E")
- ...I $P(Y,U)'=-1&($P(Y,U,10)=1) D
- ....S $P(REQI,"^",5)=+Y K Y
- ....S GONE(PXBPIECE)=""
- ....D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
- ....D EN1^PXKMAIN
- ..I PXBPIECE["-" D
- ...F PXBJ=$P(PXBPIECE,"-",1):1:$P(PXBPIECE,"-",2) D
- ....I $D(GONE(PXBJ)) Q
- ....I PXBJ'>0!(PXBJ'<(PXBCNT+1)) S BAD(PXBJ)="" Q
- ....S $P(REQI,"^",9)=$O(PXBSKY(PXBJ,0)) ;-IEN
- ....S X=$P(PXBSAM(PXBJ),U,1),Y=$$ICDDATA^ICDXCODE("DIAG",X,PXDXDATE,"E")
- ....I $P(Y,U)'=-1&($P(Y,U,10)=1) D
- .....S $P(REQI,"^",5)=+Y K Y
- .....S GONE(PXBJ)=""
- .....D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
- .....D EN1^PXKMAIN
- K GONE
- I $G(NF)&($D(BAD)) D Q
- .S (BDATA,EDATA)="" F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
- .W ! D HELP^PXBUTL0("CPTMD") W !
- .S DIR(0)="E" D ^DIR K DIR
- .S:Y=1 DATA="^P" S:Y=0!(Y="") DATA="^" K Y
- I $G(NF)&('$D(BAD)) S DATA="^P" Q
- Q
- PRI ;--Prompt for primary secondary DIAGNOSIS
- N DIR,Y,X,SEQ
- S SEQ=0 I $D(PXBKY(DATA)) S SEQ=+$O(PXBKY(DATA,"")) ;PX112
- I $G(FPRI),$P($G(PXBKY(DATA,SEQ)),U,4)'="PRIMARY" Q ;PX112
- W IOCUD,IOELALL,IOCUU
- S DIR("A",1)="ONE primary diagnosis must be established for each encounter!"
- S DIR("A")="Is this the PRIMARY DIAGNOSIS for this ENCOUNTER? "
- S DIR("B")="YES"
- S DIR("?")="One PRIMARY DIAGNOSIS must be established for each patient encounter. 'Yes' will mean PRIMARY and 'No' will mean SECONDARY."
- S DIR(0)="Y,A,O"
- D ^DIR I $G(DIRUT) G PPXIT
- PPFIN ;--Finish off variables
- I Y=1 S PRI="P^PRIMARY"
- I Y=0 S PRI="S^SECONDARY"
- S $P(REQI,"^",6)=$P(PRI,"^",1)
- S $P(REQE,"^",6)=$P(PRI,"^",2)
- PPXIT ;--EXIT
- Q
- ORD ;--Prompt for ordering resulting DIAGNOSIS
- N DIR,Y,X,SEQ
- S SEQ=0 I $D(PXBKY(DATA)) S SEQ=+$O(PXBKY(DATA,""))
- W IOCUD,IOELALL,IOCUU
- S DIR("A")="Is this Diagnosis Ordering or Resulting:"
- S DIR("B")=$P($G(PXBKY(DATA,SEQ)),U,7)
- S DIR("?")="Resulting and/or Ordering indicators are only entered if at least one of each diagnosis type exists."
- S DIR(0)="SO^O:ORDERING;R:RESULTING;OR:BOTH O&R"
- D ^DIR I $G(DIRUT) G PPXIT
- ORFIN ;--Finish off variables
- S $P(REQI,"^",7)=Y
- S $P(REQE,"^",7)=$S(Y="O":"ORDERING",Y="R":"RESULTING",1:"BOTH O&R")
- Q
- PRBLM ;--Prompt for Problem list
- N DIR,Y,X,VALL
- W IOCUD,IOELALL,IOCUU
- D WIN17^PXBCC(PXBCNT)
- S DIR("?")="^S VALL=1,VALL=$$DOUBLE1^PXBGPL2(WHAT)"
- S DIR("A")="Do you want this DIAGNOSIS added to the PROBLEM LIST? "
- S DIR("B")="NO"
- S DIR(0)="Y,A,O"
- D ^DIR
- I X="+"!(X="-") S DIR("?")="D DPOV4^PXBDPL(X)"
- I $G(DIRUT) G PPXIT
- PRPFIN ;--Finish off variables
- K PXBKYPL,PXBSKYPL,PXBSAMPL,PXBCNTPL
- K ^TMP("PXBKYPL",$J),^TMP("PXBSAMPL",$J)
- S PXBPRBLM=+Y
- PRPXIT ;--EXIT
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPPOV1 4641 printed Feb 18, 2025@23:53:27 Page 2
- PXBPPOV1 ;ISL/JVS,ESW - PROMPT POV ;4/6/05 2:41pm
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,112,121,124,199**;Aug 12, 1996;Build 51
- +2 ;
- +3 ;
- +4 ;
- +5 ;
- +6 ;
- ADDM ;--------If Multiple POV entries have been entered.
- +1 ;
- +2 ;
- +3 ;
- +4 NEW BDATA,OK,PXBLEN,PXDXDATE
- +5 SET PXDXDATE=$$CSDATE^PXDXUTL(PXBVST)
- +6 DO WIN17^PXBCC(PXBCNT)
- +7 SET NF=0
- SET PXBLEN=0
- +8 IF DATA[","
- IF $EXTRACT(DATA,1)'["@"
- SET NF=1
- Begin DoDot:1
- +9 SET PXBLEN=$LENGTH(DATA,",")
- FOR PXI=1:1:PXBLEN
- SET PXBPIECE=$PIECE(DATA,",",PXI)
- Begin DoDot:2
- +10 SET Y=$$ICDDATA^ICDXCODE("DIAG",PXBPIECE,PXDXDATE,"E")
- +11 IF $PIECE(Y,U)=-1!($PIECE(Y,U,10)'=1)
- SET BAD($GET(PXBPIECE))=""
- QUIT
- +12 SET $PIECE(REQI,"^",5)=+Y
- +13 SET PXBNPOV(PXBPIECE)=""
- +14 ;
- +15 ;--Prompt for Primary or Secondary DIAGNOSIS
- +16 ; ICD-10 Remediation note: the next two lines display code--code (ex. 369.65--369.65)
- +17 ; we think this is wrong but do not have specs to fix it.
- +18 WRITE !,"For the DIAGNOSIS: ",PXBPIECE,"--"
- +19 WRITE $PIECE(Y,U,2),!
- +20 DO WIN17^PXBCC(PXBCNT)
- +21 DO PRI^PXBPPOV1
- +22 IF $DATA(DIRUT)
- DO RSET^PXBDREQ("POV")
- QUIT
- +23 DO ORD^PXBPPOV1
- +24 NEW PXCEVIEN,PXCEAFTR,PXD
- +25 SET PXCEVIEN=PXBVST
- SET PXD=$PIECE(REQI,U,5)
- +26 ;CI's
- DO WIN17^PXBCC(PXBCNT)
- DO GET800^PXCEC800
- +27 SET PXBREQ(PXD,"I")=$GET(PXCEAFTR(800))
- +28 ;
- +29 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
- +30 DO EN1^PXKMAIN
- +31 DO RSET^PXBDREQ("POV")
- End DoDot:2
- End DoDot:1
- +32 IF $GET(NF)&($DATA(BAD))
- Begin DoDot:1
- +33 SET (BDATA,EDATA)=""
- FOR
- SET BDATA=$ORDER(BAD(BDATA))
- if BDATA=""
- QUIT
- SET EDATA=EDATA_BDATA_" "
- +34 WRITE !
- DO HELP^PXBUTL0("CPTM")
- WRITE !
- +35 SET DIR(0)="E"
- DO ^DIR
- KILL DIR,DIRUT
- +36 if Y=1
- SET DATA="^P"
- if Y=0!(Y="")
- SET DATA="^"
- KILL Y
- End DoDot:1
- QUIT
- +37 IF $GET(NF)&('$DATA(BAD))
- SET DATA="^P"
- QUIT
- +38 ;
- +39 QUIT
- +40 ;
- DELM ;--------If Multiple deleting
- +1 NEW BAD,BDATA,DELM,PXBJ,PXBLEN
- +2 SET NF=0
- SET PXBLEN=0
- SET $PIECE(DELM,"^",3)=1
- +3 IF $EXTRACT(DATA,1)="@"
- SET DATA=$PIECE(DATA,"@",2)
- SET NF=1
- Begin DoDot:1
- +4 SET PXBLEN=$LENGTH(DATA,",")
- FOR PXI=1:1:PXBLEN
- SET PXBPIECE=$PIECE(DATA,",",PXI)
- Begin DoDot:2
- +5 IF PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1)))
- SET BAD(+$GET(PXBPIECE))=""
- QUIT
- +6 IF PXBPIECE'["-"
- Begin DoDot:3
- +7 IF $DATA(GONE(PXBPIECE))
- QUIT
- +8 if PXBPIECE'?.N
- QUIT
- +9 ;-IEN
- SET $PIECE(REQI,"^",9)=$ORDER(PXBSKY(PXBPIECE,0))
- +10 SET X=$PIECE(PXBSAM(PXBPIECE),U,1)
- SET Y=$$ICDDATA^ICDXCODE("DIAG",X,PXDXDATE,"E")
- +11 IF $PIECE(Y,U)'=-1&($PIECE(Y,U,10)=1)
- Begin DoDot:4
- +12 SET $PIECE(REQI,"^",5)=+Y
- KILL Y
- +13 SET GONE(PXBPIECE)=""
- +14 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
- +15 DO EN1^PXKMAIN
- End DoDot:4
- End DoDot:3
- +16 IF PXBPIECE["-"
- Begin DoDot:3
- +17 FOR PXBJ=$PIECE(PXBPIECE,"-",1):1:$PIECE(PXBPIECE,"-",2)
- Begin DoDot:4
- +18 IF $DATA(GONE(PXBJ))
- QUIT
- +19 IF PXBJ'>0!(PXBJ'<(PXBCNT+1))
- SET BAD(PXBJ)=""
- QUIT
- +20 ;-IEN
- SET $PIECE(REQI,"^",9)=$ORDER(PXBSKY(PXBJ,0))
- +21 SET X=$PIECE(PXBSAM(PXBJ),U,1)
- SET Y=$$ICDDATA^ICDXCODE("DIAG",X,PXDXDATE,"E")
- +22 IF $PIECE(Y,U)'=-1&($PIECE(Y,U,10)=1)
- Begin DoDot:5
- +23 SET $PIECE(REQI,"^",5)=+Y
- KILL Y
- +24 SET GONE(PXBJ)=""
- +25 DO EN0^PXBSTOR(PXBVST,PATIENT,REQI)
- +26 DO EN1^PXKMAIN
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +27 KILL GONE
- +28 IF $GET(NF)&($DATA(BAD))
- Begin DoDot:1
- +29 SET (BDATA,EDATA)=""
- FOR
- SET BDATA=$ORDER(BAD(BDATA))
- if BDATA=""
- QUIT
- SET EDATA=EDATA_BDATA_" "
- +30 WRITE !
- DO HELP^PXBUTL0("CPTMD")
- WRITE !
- +31 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +32 if Y=1
- SET DATA="^P"
- if Y=0!(Y="")
- SET DATA="^"
- KILL Y
- End DoDot:1
- QUIT
- +33 IF $GET(NF)&('$DATA(BAD))
- SET DATA="^P"
- QUIT
- +34 QUIT
- PRI ;--Prompt for primary secondary DIAGNOSIS
- +1 NEW DIR,Y,X,SEQ
- +2 ;PX112
- SET SEQ=0
- IF $DATA(PXBKY(DATA))
- SET SEQ=+$ORDER(PXBKY(DATA,""))
- +3 ;PX112
- IF $GET(FPRI)
- IF $PIECE($GET(PXBKY(DATA,SEQ)),U,4)'="PRIMARY"
- QUIT
- +4 WRITE IOCUD,IOELALL,IOCUU
- +5 SET DIR("A",1)="ONE primary diagnosis must be established for each encounter!"
- +6 SET DIR("A")="Is this the PRIMARY DIAGNOSIS for this ENCOUNTER? "
- +7 SET DIR("B")="YES"
- +8 SET DIR("?")="One PRIMARY DIAGNOSIS must be established for each patient encounter. 'Yes' will mean PRIMARY and 'No' will mean SECONDARY."
- +9 SET DIR(0)="Y,A,O"
- +10 DO ^DIR
- IF $GET(DIRUT)
- GOTO PPXIT
- PPFIN ;--Finish off variables
- +1 IF Y=1
- SET PRI="P^PRIMARY"
- +2 IF Y=0
- SET PRI="S^SECONDARY"
- +3 SET $PIECE(REQI,"^",6)=$PIECE(PRI,"^",1)
- +4 SET $PIECE(REQE,"^",6)=$PIECE(PRI,"^",2)
- PPXIT ;--EXIT
- +1 QUIT
- ORD ;--Prompt for ordering resulting DIAGNOSIS
- +1 NEW DIR,Y,X,SEQ
- +2 SET SEQ=0
- IF $DATA(PXBKY(DATA))
- SET SEQ=+$ORDER(PXBKY(DATA,""))
- +3 WRITE IOCUD,IOELALL,IOCUU
- +4 SET DIR("A")="Is this Diagnosis Ordering or Resulting:"
- +5 SET DIR("B")=$PIECE($GET(PXBKY(DATA,SEQ)),U,7)
- +6 SET DIR("?")="Resulting and/or Ordering indicators are only entered if at least one of each diagnosis type exists."
- +7 SET DIR(0)="SO^O:ORDERING;R:RESULTING;OR:BOTH O&R"
- +8 DO ^DIR
- IF $GET(DIRUT)
- GOTO PPXIT
- ORFIN ;--Finish off variables
- +1 SET $PIECE(REQI,"^",7)=Y
- +2 SET $PIECE(REQE,"^",7)=$SELECT(Y="O":"ORDERING",Y="R":"RESULTING",1:"BOTH O&R")
- +3 QUIT
- PRBLM ;--Prompt for Problem list
- +1 NEW DIR,Y,X,VALL
- +2 WRITE IOCUD,IOELALL,IOCUU
- +3 DO WIN17^PXBCC(PXBCNT)
- +4 SET DIR("?")="^S VALL=1,VALL=$$DOUBLE1^PXBGPL2(WHAT)"
- +5 SET DIR("A")="Do you want this DIAGNOSIS added to the PROBLEM LIST? "
- +6 SET DIR("B")="NO"
- +7 SET DIR(0)="Y,A,O"
- +8 DO ^DIR
- +9 IF X="+"!(X="-")
- SET DIR("?")="D DPOV4^PXBDPL(X)"
- +10 IF $GET(DIRUT)
- GOTO PPXIT
- PRPFIN ;--Finish off variables
- +1 KILL PXBKYPL,PXBSKYPL,PXBSAMPL,PXBCNTPL
- +2 KILL ^TMP("PXBKYPL",$JOB),^TMP("PXBSAMPL",$JOB)
- +3 SET PXBPRBLM=+Y
- PRPXIT ;--EXIT
- +1 QUIT
- +2 ;