ACMPROB ; IHS/TUCSON/TMJ - DISPLAY OF PCC PROBLEM LIST ; [ 07/11/1999 8:59 PM ]
;;2.0;ACM CASE MANAGEMENT SYSTEM;**1**;JAN 10, 1996
;IHS/CMI/LAB - y2k patch 1
;Called from CASE MANAGEMENT SYSTEM to display PCC problems
;ACMPTNO must equal the patient DFN
;EP;ENTRY POINT
;begin Y2K
;S ACMTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)",ACMTTAT="A" ;Y2000
S ACMTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))",ACMTTAT="A" ;Y2000
;end Y2K
D COMMON
S ACMTTAT="I"
D COMMON
K ACMTCVD,ACMTQ,Y
D PROBX
Q
COMMON ;
I '$D(^AUPNPROB("AC",ACMPTNO)) W !!?4,"********** No ",$S(ACMTTAT="A":" ACTIVE",1:"INACTIVE")," Problems in PCC file for this Patient **********",!?4,"(To update the PCC problem list use PCC encounter form.)",! Q
K ACMTDFT
S ACMTNDF=0,ACMTFAC=""
F ACMTQ=0:0 S ACMTFAC=$O(^AUPNPROB("AA",ACMPTNO,ACMTFAC)) Q:'ACMTFAC D PROBSCH
I ACMTNDF=0 W !!?4,"********** No ",$S(ACMTTAT="A":" ACTIVE",1:"INACTIVE")," Problems in PCC file for this Patient **********",!?4,"(To update the PCC problem list use PCC encounter form.)",! Q
W !!?4,"****************"_$S(ACMTTAT="A":" ACTIVE ",1:" INACTIVE ")_"PCC PROBLEMS AND NOTES *********************",!?4,"(To update PCC problem list use PCC encounter form.)",!
S ACMTFPP=""
F ACMTQ=0:0 S ACMTFPP=$O(ACMTDFT(ACMTFPP)) Q:ACMTFPP="" S ACMTDFN=ACMTDFT(ACMTFPP) D PROBDSP
PROBX K ACMTDFT,ACMTNDF,ACMTFPP,ACMTFAC,ACMTPLN,ACMTPBN,ACMTDTM,ACMTDTN,ACMTPRB,ACMTTAT,ACMTNFP,ACMTNRQ,ACMTPNM,ACMTDFN,ACMTFCN,ACMTICD,ACMTICL,ACMTILN,ACMTN,ACMTNFL,ACMTNSH,ACMTNAB,ACMTVSC,ACMTITE
Q
PROBSCH ;
S ACMTPRB=""
F ACMTQ=0:0 S ACMTPRB=$O(^AUPNPROB("AA",ACMPTNO,ACMTFAC,ACMTPRB)) Q:ACMTPRB="" S ACMTDFN=$O(^(ACMTPRB,"")) S:$P(^AUPNPROB(ACMTDFN,0),U,12)=ACMTTAT ACMTNDF=ACMTNDF+1,ACMTDFT(ACMTFAC_ACMTPRB)=ACMTDFN
Q
PROBDSP ;
S ACMTN=^AUPNPROB(ACMTDFN,0),ACMTNRQ=$P(ACMTN,U,5)
D GETNARR
E S ACMTNRQ=""
S ACMTITE=$P(ACMTN,U,6)
D GETSITE
S ACMTPNM=$P(ACMTN,U,7),ACMTPNM=ACMTNAB_ACMTPNM,Y=$P(ACMTN,U,3)
X ACMTCVD
S ACMTDTM=Y,Y=$P(ACMTN,U,8)
X ACMTCVD
S ACMTDTN=Y,ACMTPLN=ACMTPNM_$E(" ",1,12-$L(ACMTPNM))_ACMTDTM
W ?3,ACMTPLN
S ACMTICL=24,ACMTILN=58
D PRTICD,NOTEDSP
Q
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
S ACMTNFP=0
F ACMTQ=0:0 S ACMTNFP=$O(^AUPNPROB(ACMTDFN,11,ACMTNFP)) Q:'ACMTNFP D DSPFACN
Q
DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
Q:$D(^AUPNPROB(ACMTDFN,11,ACMTNFP,11,0))'=1!($O(^(0))="")
S ACMTITE=^AUPNPROB(ACMTDFN,11,ACMTNFP,0)
D GETSITE
S ACMTFCN=ACMTNAB,ACMTNDF=0
F ACMTQ=0:0 S ACMTNDF=$O(^AUPNPROB(ACMTDFN,11,ACMTNFP,11,ACMTNDF)) Q:'ACMTNDF D DSPN ; ACC
Q
DSPN ; DISPLAY SINGLE NOTE
S ACMTN=^AUPNPROB(ACMTDFN,11,ACMTNFP,11,ACMTNDF,0) ;/IHS/OHPRD/TMJ 9/20/95
Q:$P(ACMTN,U,4)="I"
F ACMTQ=0:0 Q:$E(ACMTFCN)'=" " S ACMTFCN=$E(ACMTFCN,2,99)
W ?3,ACMTPNM," (",ACMTFCN,$P(ACMTN,U,1),")",?29,$P(ACMTN,U,3),!
Q
;
PRTICD ;
S:ACMTNRQ="" ACMTNRQ="<no narrative provided>"
S ACMTICD="",ACMTTXT=ACMTICD
D PRTTXT
Q
;
PRTTXT ; GENERALIZED TEXT PRINTER
S ACMTDLT=1,ACMTILN=80-ACMTICL-1
F ACMTQ=0:0 S:ACMTNRQ]""&(($L(ACMTNRQ)+$L(ACMTTXT)+2)<255) ACMTTXT=$S(ACMTTXT]"":ACMTTXT_"; ",1:"")_ACMTNRQ,ACMTNRQ="" Q:ACMTTXT="" D:ACMTQ>15 PAUSE D PRTTXT2
K ACMTILN,ACMTDLT,ACMTF,ACMTC,ACMTTXT
Q
PRTTXT2 D GETFRAG
W ?ACMTICL+5,ACMTF,!
S ACMTICL=ACMTICL+ACMTDLT,ACMTILN=ACMTILN-ACMTDLT,ACMTDLT=0
Q
GETFRAG I $L(ACMTTXT)<ACMTILN S ACMTF=ACMTTXT,ACMTTXT="" Q
F ACMTC=ACMTILN:-1:1 Q:$E(ACMTTXT,ACMTC)=" "
S ACMTF=$E(ACMTTXT,1,ACMTC-1),ACMTTXT=$E(ACMTTXT,ACMTC+1,255)
Q
;
GETNARR ;
I ACMTNRQ]"" S ACMTNRQ=$S($D(^AUTNPOV(ACMTNRQ)):$P(^AUTNPOV(ACMTNRQ,0),U,1),1:"***** "_ACMTNRQ_" *****")
E S ACMTNRQ=""
Q
;
GETSITE ;
S:ACMTITE="" ACMTITE="null"
S %=$S($D(^AUTTLOC(ACMTITE,0)):^(0),1:""),ACMTNFL=$P(%,U,1),ACMTNFL=$S($D(^DIC(4,ACMTITE,0)):$P(^(0),U,1),1:"<"_ACMTITE_">"),ACMTNSH=$P(%,U,2)
I ACMTNSH="" S ACMTNSH="<"_ACMTITE_">"
S ACMTNAB=$J($P(%,U,7),4)
I ACMTNAB="" S ACMTNAB="<"_ACMTITE_">"
Q
PAUSE ;
I IOST["C-" S DIR(0)="EOA",DIR("A")="Press <ENTER> to continue..... " D ^DIR K DIR
Q
ACMPROB ; IHS/TUCSON/TMJ - DISPLAY OF PCC PROBLEM LIST ; [ 07/11/1999 8:59 PM ]
+1 ;;2.0;ACM CASE MANAGEMENT SYSTEM;**1**;JAN 10, 1996
+2 ;IHS/CMI/LAB - y2k patch 1
+3 ;Called from CASE MANAGEMENT SYSTEM to display PCC problems
+4 ;ACMPTNO must equal the patient DFN
+5 ;EP;ENTRY POINT
+6 ;begin Y2K
+7 ;S ACMTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)",ACMTTAT="A" ;Y2000
+8 ;Y2000
SET ACMTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))"
SET ACMTTAT="A"
+9 ;end Y2K
+10 DO COMMON
+11 SET ACMTTAT="I"
+12 DO COMMON
+13 KILL ACMTCVD,ACMTQ,Y
+14 DO PROBX
+15 QUIT
COMMON ;
+1 IF '$DATA(^AUPNPROB("AC",ACMPTNO))
WRITE !!?4,"********** No ",$SELECT(ACMTTAT="A":" ACTIVE",1:"INACTIVE")," Problems in PCC file for this Patient **********",!?4,"(To update the PCC problem list use PCC encounter form.)",!
QUIT
+2 KILL ACMTDFT
+3 SET ACMTNDF=0
SET ACMTFAC=""
+4 FOR ACMTQ=0:0
SET ACMTFAC=$ORDER(^AUPNPROB("AA",ACMPTNO,ACMTFAC))
IF 'ACMTFAC
QUIT
DO PROBSCH
+5 IF ACMTNDF=0
WRITE !!?4,"********** No ",$SELECT(ACMTTAT="A":" ACTIVE",1:"INACTIVE")," Problems in PCC file for this Patient **********",!?4,"(To update the PCC problem list use PCC encounter form.)",!
QUIT
+6 WRITE !!?4,"****************"_$SELECT(ACMTTAT="A":" ACTIVE ",1:" INACTIVE ")_"PCC PROBLEMS AND NOTES *********************",!?4,"(To update PCC problem list use PCC encounter form.)",!
+7 SET ACMTFPP=""
+8 FOR ACMTQ=0:0
SET ACMTFPP=$ORDER(ACMTDFT(ACMTFPP))
IF ACMTFPP=""
QUIT
SET ACMTDFN=ACMTDFT(ACMTFPP)
DO PROBDSP
PROBX KILL ACMTDFT,ACMTNDF,ACMTFPP,ACMTFAC,ACMTPLN,ACMTPBN,ACMTDTM,ACMTDTN,ACMTPRB,ACMTTAT,ACMTNFP,ACMTNRQ,ACMTPNM,ACMTDFN,ACMTFCN,ACMTICD,ACMTICL,ACMTILN,ACMTN,ACMTNFL,ACMTNSH,ACMTNAB,ACMTVSC,ACMTITE
+1 QUIT
PROBSCH ;
+1 SET ACMTPRB=""
+2 FOR ACMTQ=0:0
SET ACMTPRB=$ORDER(^AUPNPROB("AA",ACMPTNO,ACMTFAC,ACMTPRB))
IF ACMTPRB=""
QUIT
SET ACMTDFN=$ORDER(^(ACMTPRB,""))
IF $PIECE(^AUPNPROB(ACMTDFN,0),U,12)=ACMTTAT
SET ACMTNDF=ACMTNDF+1
SET ACMTDFT(ACMTFAC_ACMTPRB)=ACMTDFN
+3 QUIT
PROBDSP ;
+1 SET ACMTN=^AUPNPROB(ACMTDFN,0)
SET ACMTNRQ=$PIECE(ACMTN,U,5)
+2 DO GETNARR
+3 IF '$TEST
SET ACMTNRQ=""
+4 SET ACMTITE=$PIECE(ACMTN,U,6)
+5 DO GETSITE
+6 SET ACMTPNM=$PIECE(ACMTN,U,7)
SET ACMTPNM=ACMTNAB_ACMTPNM
SET Y=$PIECE(ACMTN,U,3)
+7 XECUTE ACMTCVD
+8 SET ACMTDTM=Y
SET Y=$PIECE(ACMTN,U,8)
+9 XECUTE ACMTCVD
+10 SET ACMTDTN=Y
SET ACMTPLN=ACMTPNM_$EXTRACT(" ",1,12-$LENGTH(ACMTPNM))_ACMTDTM
+11 WRITE ?3,ACMTPLN
+12 SET ACMTICL=24
SET ACMTILN=58
+13 DO PRTICD
DO NOTEDSP
+14 QUIT
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
+1 SET ACMTNFP=0
+2 FOR ACMTQ=0:0
SET ACMTNFP=$ORDER(^AUPNPROB(ACMTDFN,11,ACMTNFP))
IF 'ACMTNFP
QUIT
DO DSPFACN
+3 QUIT
DSPFACN ; DISPLAY NOTES FOR SELECTED APSHCFACILITY
+1 IF $DATA(^AUPNPROB(ACMTDFN,11,ACMTNFP,11,0))'=1!($ORDER(^(0))="")
QUIT
+2 SET ACMTITE=^AUPNPROB(ACMTDFN,11,ACMTNFP,0)
+3 DO GETSITE
+4 SET ACMTFCN=ACMTNAB
SET ACMTNDF=0
+5 ; ACC
FOR ACMTQ=0:0
SET ACMTNDF=$ORDER(^AUPNPROB(ACMTDFN,11,ACMTNFP,11,ACMTNDF))
IF 'ACMTNDF
QUIT
DO DSPN
+6 QUIT
DSPN ; DISPLAY SINGLE NOTE
+1 ;/IHS/OHPRD/TMJ 9/20/95
SET ACMTN=^AUPNPROB(ACMTDFN,11,ACMTNFP,11,ACMTNDF,0)
+2 IF $PIECE(ACMTN,U,4)="I"
QUIT
+3 FOR ACMTQ=0:0
IF $EXTRACT(ACMTFCN)'=" "
QUIT
SET ACMTFCN=$EXTRACT(ACMTFCN,2,99)
+4 WRITE ?3,ACMTPNM," (",ACMTFCN,$PIECE(ACMTN,U,1),")",?29,$PIECE(ACMTN,U,3),!
+5 QUIT
+6 ;
PRTICD ;
+1 IF ACMTNRQ=""
SET ACMTNRQ="<no narrative provided>"
+2 SET ACMTICD=""
SET ACMTTXT=ACMTICD
+3 DO PRTTXT
+4 QUIT
+5 ;
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET ACMTDLT=1
SET ACMTILN=80-ACMTICL-1
+2 FOR ACMTQ=0:0
IF ACMTNRQ]""&(($LENGTH(ACMTNRQ)+$LENGTH(ACMTTXT)+2)<255)
SET ACMTTXT=$SELECT(ACMTTXT]"":ACMTTXT_"; ",1:"")_ACMTNRQ
SET ACMTNRQ=""
IF ACMTTXT=""
QUIT
IF ACMTQ>15
DO PAUSE
DO PRTTXT2
+3 KILL ACMTILN,ACMTDLT,ACMTF,ACMTC,ACMTTXT
+4 QUIT
PRTTXT2 DO GETFRAG
+1 WRITE ?ACMTICL+5,ACMTF,!
+2 SET ACMTICL=ACMTICL+ACMTDLT
SET ACMTILN=ACMTILN-ACMTDLT
SET ACMTDLT=0
+3 QUIT
GETFRAG IF $LENGTH(ACMTTXT)<ACMTILN
SET ACMTF=ACMTTXT
SET ACMTTXT=""
QUIT
+1 FOR ACMTC=ACMTILN:-1:1
IF $EXTRACT(ACMTTXT,ACMTC)=" "
QUIT
+2 SET ACMTF=$EXTRACT(ACMTTXT,1,ACMTC-1)
SET ACMTTXT=$EXTRACT(ACMTTXT,ACMTC+1,255)
+3 QUIT
+4 ;
GETNARR ;
+1 IF ACMTNRQ]""
SET ACMTNRQ=$SELECT($DATA(^AUTNPOV(ACMTNRQ)):$PIECE(^AUTNPOV(ACMTNRQ,0),U,1),1:"***** "_ACMTNRQ_" *****")
+2 IF '$TEST
SET ACMTNRQ=""
+3 QUIT
+4 ;
GETSITE ;
+1 IF ACMTITE=""
SET ACMTITE="null"
+2 SET %=$SELECT($DATA(^AUTTLOC(ACMTITE,0)):^(0),1:"")
SET ACMTNFL=$PIECE(%,U,1)
SET ACMTNFL=$SELECT($DATA(^DIC(4,ACMTITE,0)):$PIECE(^(0),U,1),1:"<"_ACMTITE_">")
SET ACMTNSH=$PIECE(%,U,2)
+3 IF ACMTNSH=""
SET ACMTNSH="<"_ACMTITE_">"
+4 SET ACMTNAB=$JUSTIFY($PIECE(%,U,7),4)
+5 IF ACMTNAB=""
SET ACMTNAB="<"_ACMTITE_">"
+6 QUIT
PAUSE ;
+1 IF IOST["C-"
SET DIR(0)="EOA"
SET DIR("A")="Press <ENTER> to continue..... "
DO ^DIR
KILL DIR
+2 QUIT
