APCDHOS ; IHS/CMI/LAB - DISPLAY HISTORY OF SURGERY ;
;;2.0;IHS PCC SUITE;**1,11,12**;MAY 14, 2009;Build 3
HOS ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
; <SETUP>
D DATE
S APCDTICF="S"
I '$D(^AUPNVPRC("AC",APCDPAT)) W !!,"***************** NO SURGICAL HISTORY ON FILE ******************",!! Q
W !!,"************************ SURGICAL HISTORY **********************",!!
S APCDTCNT=0
K ^TMP($J,"APCDMPRCTAX") ;IHS/CMI/LAB - ICD SPEED UP
S F=$NA(^TMP($J,"APCDMPRCTAX")) ;IHS/CMI/LAB - ICD SPEED UP
D BLDTAX^ATXAPI("APCH MINOR SURGICAL PROCS",F,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0))) ;IHS/CMI/LAB - ICD SPEED UP
; <DISPLAY>
S APCDTIVD=0 F APCDTQ=0:0 S APCDTIVD=$O(^AUPNVPRC("AA",APCDPAT,APCDTIVD)) Q:'APCDTIVD S APCDTDFN=0 F APCDTQ=0:0 S APCDTDFN=$O(^AUPNVPRC("AA",APCDPAT,APCDTIVD,APCDTDFN)) Q:'APCDTDFN D HOSDSP
I 'APCDTCNT W "Minor procedures are on file but have not been displayed.",!
; <CLEANUP>
HOSX K APCDTDFN,APCDTICD,APCDTNRQ,APCDTDAT,APCDTDS,APCDTICL,APCDTIVD,APCDTCOD,APCDTCNT,APCDTN,APCDTICF,APCDTCVD,APCDTNTD,APCDTQ,Y
K ^TMP($J,"APCDMPRCTAX")
Q
HOSDSP S APCDTN=^AUPNVPRC(APCDTDFN,0)
S APCDTICD=$P(APCDTN,U)
D HOSCHK Q:APCDTICD=""
S APCDTCNT=APCDTCNT+1
D GETICDOP
S Y=$P(APCDTN,U,3),Y=+^AUPNVSIT(Y,0)\1 X APCDTCVD S APCDTDAT=Y
S APCDTNRQ=$P(APCDTN,U,4)
D GETNARR
S APCDTDS="DATE?" D
.S Y=$P(APCDTN,U,6) I Y]"" X APCDTCVD S APCDTDS=Y Q
.S Y=(9999999-APCDTIVD) X APCDTCVD S APCDTDS=Y
W APCDTDS,?12,$$VAL^XBDIQ1(9000010.08,APCDTDFN,.01) S APCDTNTD=APCDTDAT S APCDTICL=22 D PRTICD
Q
HOSCHK ;
;S APCDTCOD=$P($$ICDDX^ICDEX(APCDTICD),U,2)
;I $$ICD^ATXAPI(APCDTICD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S APCDTICD=""
S:$D(^TMP($J,"APCDMPRCTAX",APCDTICD)) APCDTICD="" Q
Q
;
GETICDDX ;
S:APCDTICF="S" APCDTICD=$P($$ICDDX^ICDEX(APCDTICD,$$VD^APCLV($P(APCDTN,U,3))),U,4)
Q
GETICDOP ;
S:APCDTICF="S" APCDTICD=$P($$ICDOP^ICDEX(APCDTICD,$$VD^APCLV($P(APCDTN,U,3)),,"I"),U,5)
Q
;
PRTICD ;
S:APCDTNRQ="" APCDTNRQ="<no narrative provided>" S APCDTICD=""
S APCDTTXT=APCDTICD D PRTTXT
Q
;
PRTTXT ; GENERALIZED TEXT PRINTER
S APCDTDLT=1,APCDTILN=80-APCDTICL-1
F APCDTQ=0:0 S:APCDTNRQ]""&(($L(APCDTNRQ)+$L(APCDTTXT)+2)<255) APCDTTXT=$S(APCDTTXT]"":APCDTTXT_"; ",1:"")_APCDTNRQ,APCDTNRQ="" Q:APCDTTXT="" D PRTTXT2
K APCDTILN,APCDTDLT,APCDTF,APCDTC,APCDTTXT
Q
PRTTXT2 D GETFRAG W ?APCDTICL W APCDTF,! S APCDTICL=APCDTICL+APCDTDLT,APCDTILN=APCDTILN-APCDTDLT,APCDTDLT=0
Q
GETFRAG I $L(APCDTTXT)<APCDTILN S APCDTF=APCDTTXT,APCDTTXT="" Q
F APCDTC=APCDTILN:-1:1 Q:$E(APCDTTXT,APCDTC)=" "
S APCDTF=$E(APCDTTXT,1,APCDTC-1),APCDTTXT=$E(APCDTTXT,APCDTC+1,255)
Q
;
GETNARR ;
I APCDTNRQ]"" S APCDTNRQ=$S($D(^AUTNPOV(APCDTNRQ)):$P(^AUTNPOV(APCDTNRQ,0),U),1:"***** "_APCDTNRQ_" *****")
E S APCDTNRQ=""
Q
;
GETSITEV ;
S %=^AUPNVSIT(APCDTVDF,0),APCDTVSC=$P(%,U,7),APCDTITE=$P(%,U,6)
GETSITE ;
S:APCDTITE="" APCDTITE="null"
S %=$G(^AUTTLOC(APCDTITE,0))
S APCDTNFL=$P(%,U),APCDTNFL=$S($D(^DIC(4,APCDTITE,0)):$P(^(0),U),1:"<"_APCDTITE_">")
S APCDTNSH=$P(%,U,2) I APCDTNSH="" S APCDTNSH="<"_APCDTITE_">"
S APCDTNAB=$J($P(%,U,7),4) I APCDTNAB="" S APCDTNAB="<"_APCDTITE_">"
Q
DATE S APCDTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))" K Y
Q
APCDHOS ; IHS/CMI/LAB - DISPLAY HISTORY OF SURGERY ;
+1 ;;2.0;IHS PCC SUITE;**1,11,12**;MAY 14, 2009;Build 3
HOS ; ************* HISTORY OF SURGERY * 9000010.08 (V PROCEDURE) *******
+1 ; <SETUP>
+2 DO DATE
+3 SET APCDTICF="S"
+4 IF '$DATA(^AUPNVPRC("AC",APCDPAT))
WRITE !!,"***************** NO SURGICAL HISTORY ON FILE ******************",!!
QUIT
+5 WRITE !!,"************************ SURGICAL HISTORY **********************",!!
+6 SET APCDTCNT=0
+7 ;IHS/CMI/LAB - ICD SPEED UP
KILL ^TMP($JOB,"APCDMPRCTAX")
+8 ;IHS/CMI/LAB - ICD SPEED UP
SET F=$NAME(^TMP($JOB,"APCDMPRCTAX"))
+9 ;IHS/CMI/LAB - ICD SPEED UP
DO BLDTAX^ATXAPI("APCH MINOR SURGICAL PROCS",F,$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)))
+10 ; <DISPLAY>
+11 SET APCDTIVD=0
FOR APCDTQ=0:0
SET APCDTIVD=$ORDER(^AUPNVPRC("AA",APCDPAT,APCDTIVD))
IF 'APCDTIVD
QUIT
SET APCDTDFN=0
FOR APCDTQ=0:0
SET APCDTDFN=$ORDER(^AUPNVPRC("AA",APCDPAT,APCDTIVD,APCDTDFN))
IF 'APCDTDFN
QUIT
DO HOSDSP
+12 IF 'APCDTCNT
WRITE "Minor procedures are on file but have not been displayed.",!
+13 ; <CLEANUP>
HOSX KILL APCDTDFN,APCDTICD,APCDTNRQ,APCDTDAT,APCDTDS,APCDTICL,APCDTIVD,APCDTCOD,APCDTCNT,APCDTN,APCDTICF,APCDTCVD,APCDTNTD,APCDTQ,Y
+1 KILL ^TMP($JOB,"APCDMPRCTAX")
+2 QUIT
HOSDSP SET APCDTN=^AUPNVPRC(APCDTDFN,0)
+1 SET APCDTICD=$PIECE(APCDTN,U)
+2 DO HOSCHK
IF APCDTICD=""
QUIT
+3 SET APCDTCNT=APCDTCNT+1
+4 DO GETICDOP
+5 SET Y=$PIECE(APCDTN,U,3)
SET Y=+^AUPNVSIT(Y,0)\1
XECUTE APCDTCVD
SET APCDTDAT=Y
+6 SET APCDTNRQ=$PIECE(APCDTN,U,4)
+7 DO GETNARR
+8 SET APCDTDS="DATE?"
Begin DoDot:1
+9 SET Y=$PIECE(APCDTN,U,6)
IF Y]""
XECUTE APCDTCVD
SET APCDTDS=Y
QUIT
+10 SET Y=(9999999-APCDTIVD)
XECUTE APCDTCVD
SET APCDTDS=Y
End DoDot:1
+11 WRITE APCDTDS,?12,$$VAL^XBDIQ1(9000010.08,APCDTDFN,.01)
SET APCDTNTD=APCDTDAT
SET APCDTICL=22
DO PRTICD
+12 QUIT
HOSCHK ;
+1 ;S APCDTCOD=$P($$ICDDX^ICDEX(APCDTICD),U,2)
+2 ;I $$ICD^ATXAPI(APCDTICD,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) S APCDTICD=""
+3 IF $DATA(^TMP($JOB,"APCDMPRCTAX",APCDTICD))
SET APCDTICD=""
QUIT
+4 QUIT
+5 ;
GETICDDX ;
+1 IF APCDTICF="S"
SET APCDTICD=$PIECE($$ICDDX^ICDEX(APCDTICD,$$VD^APCLV($PIECE(APCDTN,U,3))),U,4)
+2 QUIT
GETICDOP ;
+1 IF APCDTICF="S"
SET APCDTICD=$PIECE($$ICDOP^ICDEX(APCDTICD,$$VD^APCLV($PIECE(APCDTN,U,3)),,"I"),U,5)
+2 QUIT
+3 ;
PRTICD ;
+1 IF APCDTNRQ=""
SET APCDTNRQ="<no narrative provided>"
SET APCDTICD=""
+2 SET APCDTTXT=APCDTICD
DO PRTTXT
+3 QUIT
+4 ;
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET APCDTDLT=1
SET APCDTILN=80-APCDTICL-1
+2 FOR APCDTQ=0:0
IF APCDTNRQ]""&(($LENGTH(APCDTNRQ)+$LENGTH(APCDTTXT)+2)<255)
SET APCDTTXT=$SELECT(APCDTTXT]"":APCDTTXT_"; ",1:"")_APCDTNRQ
SET APCDTNRQ=""
IF APCDTTXT=""
QUIT
DO PRTTXT2
+3 KILL APCDTILN,APCDTDLT,APCDTF,APCDTC,APCDTTXT
+4 QUIT
PRTTXT2 DO GETFRAG
WRITE ?APCDTICL
WRITE APCDTF,!
SET APCDTICL=APCDTICL+APCDTDLT
SET APCDTILN=APCDTILN-APCDTDLT
SET APCDTDLT=0
+1 QUIT
GETFRAG IF $LENGTH(APCDTTXT)<APCDTILN
SET APCDTF=APCDTTXT
SET APCDTTXT=""
QUIT
+1 FOR APCDTC=APCDTILN:-1:1
IF $EXTRACT(APCDTTXT,APCDTC)=" "
QUIT
+2 SET APCDTF=$EXTRACT(APCDTTXT,1,APCDTC-1)
SET APCDTTXT=$EXTRACT(APCDTTXT,APCDTC+1,255)
+3 QUIT
+4 ;
GETNARR ;
+1 IF APCDTNRQ]""
SET APCDTNRQ=$SELECT($DATA(^AUTNPOV(APCDTNRQ)):$PIECE(^AUTNPOV(APCDTNRQ,0),U),1:"***** "_APCDTNRQ_" *****")
+2 IF '$TEST
SET APCDTNRQ=""
+3 QUIT
+4 ;
GETSITEV ;
+1 SET %=^AUPNVSIT(APCDTVDF,0)
SET APCDTVSC=$PIECE(%,U,7)
SET APCDTITE=$PIECE(%,U,6)
GETSITE ;
+1 IF APCDTITE=""
SET APCDTITE="null"
+2 SET %=$GET(^AUTTLOC(APCDTITE,0))
+3 SET APCDTNFL=$PIECE(%,U)
SET APCDTNFL=$SELECT($DATA(^DIC(4,APCDTITE,0)):$PIECE(^(0),U),1:"<"_APCDTITE_">")
+4 SET APCDTNSH=$PIECE(%,U,2)
IF APCDTNSH=""
SET APCDTNSH="<"_APCDTITE_">"
+5 SET APCDTNAB=$JUSTIFY($PIECE(%,U,7),4)
IF APCDTNAB=""
SET APCDTNAB="<"_APCDTITE_">"
+6 QUIT
DATE SET APCDTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))"
KILL Y
+1 QUIT
