ADGCRB5 ; IHS/ADC/PDW/ENM - A SHEET lines 8-11 ; [ 08/25/2004 11:38 AM ]
;;5.3;PIMS;**1001,1008,1009,1010,1016,1017,1019**;APR 26, 2002;Build 3
;IHS/ITSC/WAR 8/1/2004 Modified 2nd line to be consistent with version
; number and IHS patch number. Need to copy this routine and rename
; it to match current naming scheme for PIMS. Original 2nd line is
; listed below:
;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999
;
;cmi/anch/maw 12/7/2007 patch 1008 added code set versioning VPOV,VPRC
;cmi/anch/maw 02/21/2008 PATCH 1009 mods to VPRC requirement 57
;cmi/anch/maw 04/07/2009 PATCH 1010 mods to check for .05 DIAGNOSIS field before displaying
;
A ;EP -- driver
D VSIT Q:'DGVSDA K DGZN D H8,VPOV,H9,VPRC,H10,VINP Q
;
H8 ; -- sub heading 8
;W !,DGLIN,!,"26 ICD9 27 Hosp Acq",?24,"28 Established DX",!,DGLIN1 Q
;ihs/cmi/maw 07/02/2012 PATCH 1016 changed ICD9 to ICD
W !,DGLIN,!,"26 ICD 27 Hosp Acq",?24,"28 Established DX",!,DGLIN1 Q
;
VSIT ; -- visit DGFN
;IHS/DSD/ENM 10/18/99 A Break Cmd was removed from this line
S DGVSDA=$$VISIT
I DGDS,'DGVSDA W !!,"*** No visit for day surgery entry yet ***" Q
W:'DGVSDA !!,"*** no visit created for this admission - incomplete ***"
Q
;
VPOV ; -- diagnosis
N X,Y,Z,DX S X=0 F S X=$O(^AUPNVPOV("AD",DGVSDA,X)) Q:'X D
. Q:'$D(^AUPNVPOV(X,0)) S Y=^(0) Q:'Y!('$D(^ICD9(+Y,0)))
. W !?3,$P($$ICDDX^ICDEX(+Y,0),U,2),?13,$S($P(Y,U,7)=1:"X",1:"") ;cmi/anch/maw 12/7/2007 csv patch 1008
. S:$P(Y,U,9)'="" DGPOVDA=X,DGPOVN0=Y
. Q:'+$P(Y,U,4)!('$D(^AUTNPOV(+$P(Y,U,4),0)))
. S Z=$$GET1^DIQ(9000010.07,X,.04) I $L(Z)<53 W ?27,Z Q ;ihs/cmi/maw 08/10/2014 patch 1017
. ;S Z=$P(^AUTNPOV(+$P(Y,U,4),0),U) I $L(Z)<53 W ?27,Z Q
. D WRAP(Z,27,79,"")
Q
;
H9 ; -- sub heading 9
;W !,DGLIN1,!,"29 ICD9 30 DX",?18,"31 Op & Selec Procedures"
;ihs/cmi/maw 07/02/2012 PATCH 1016 changed ICD9 to ICD
W !,DGLIN1,!,"29 ICD 30 DX",?18,"31 Op & Selec Procedures"
W ?55,"32 Post-Op 33 33a Op"
W !?3,"Code",?58,"Infec Date Phy Code",!,DGLIN1 Q
;
VPRC ; -- procedures
N DGX,DGY,OPI,OP S DGX=0 F S DGX=$O(^AUPNVPRC("AD",DGVSDA,DGX)) Q:'DGX D
. Q:'$D(^AUPNVPRC(DGX,0)) S DGY=^(0) Q:'DGY!('$D(^ICD0(+DGY,0)))
. ;W !?3,$P(^ICD0(+DGY,0),U)
. S OPI=$$GET1^DIQ(9000010.08,DGX,.01,"I")
. S OP=$$ICDOP^ICDEX(OPI,DT,,"I")
. W !?3,$P(OP,U,2)
. ;W !?3,$P($$ICDOP^ICDCODE(+DGY),U,2)
. I $P(DGY,U,5)]"" W ?11,$P($G(^ICD9($P(DGY,U,5),0)),U) ;cmi/maw 2/21/2008 PATCH 1009 requirement 57 updated 4/7/2009
.; S X=$P(DGY,U,5) I X]"" W ?12,$P($G(^ICD9(X,0)),U) ;dx
. S X=$P(DGY,U,4) I X]"" D ;prov narr
.. Q:'+$P(DGY,U,4)!('$D(^AUTNPOV(+$P(DGY,U,4),0)))
.. S X=$P(^AUTNPOV(+$P(DGY,U,4),0),U) I $L(X)<38 W ?21,X Q
.. D WRAP(X,21,58,"")
. W ?60,$S($P(DGY,U,8)="Y":"YES",1:" NO"),?66,$E($P(DGY,U,6),4,7)
. Q:'+$P(DGY,U,11)
. I $P(^DD(9000010.06,.01,0),U,2)["200" D Q
.. W ?72,$$VAL^XBDIQ1(200,+$P(DGY,U,11),9999999.039)
. W ?72,$$VAL^XBDIQ1(6,+$P(DGY,U,11),9999999.039)
Q
;
H10 ; -- sub heading 10
I DGDS W !,DGLIN1,!,"34 Post-op Comments",! Q
W !,DGLIN1,!,"34 Discharge Type"
W ?27,"35 Facility Transferred To",?63,"36 Facility Code",! Q
;
VINP ; -- hospitalization
I DGDS D DSCMTS Q
N X,X1,Y S X=$O(^AUPNVINP("AD",DGVSDA,0)) Q:'X
Q:'$D(^AUPNVINP(X,0)) S Y=^(0)
S X=$P(Y,U,6) I X]"" W ?3,$E($P(^DG(405.1,X,0),U),1,24) ;dsch type
S X1=$P(Y,U,9) I +X1 D ; -- facility & code
. W ?30,$P(@(U_$P(X1,";",2)_+X1_",0)"),U)
. I $P(X1,";",2)'="DIC(4," Q
. W ?66,$P($G(^AUTTLOC(+X1,0)),U,10)
;
; -- sub heading 11
W !,DGLIN1,!,"37 Disch Service",?24,"38 Disch Srv Code"
W ?55,"39 # Consults",!
;
S X1=$P(Y,U,5) I +X1 D ; -- discharge service & code
. Q:'$D(^DIC(45.7,+X1,0)) W ?3,$P(^(0),U)
. Q:'$D(^DIC(45.7,X1,9999999)) W ?30,$P(^(9999999),U)
W ?63,$P(Y,U,8) ;# consults
Q
;
DSCMTS ; -- day surgery comments
NEW S0,S2,Y,LINE
S S0=$G(^ADGDS(DFN,"DS",DGDS,0)),S2=$G(^(2)),LINE=""
S Y=$P(S0,U,7) I Y]"" D DD^%DT S LINE=LINE_"Sent to Observation @ "_Y
I $P(S2,U,5)="Y" S LINE=LINE_" UNESCORTED"
S LINE=LINE_$$ADMDS
S LINE=LINE_" "_$P(S2,U,6) W ?2,LINE
Q
;
ADMDS() ; -- admit after ds
NEW SDT,X1,X2,X,Y,SAV,LMT,ADT
;IHS/ITSC/WAR 6/10/2004 PATCH #1001 fix to address new location of data
;S (SDT,X1)=$P(DGN,U),X2=$P(DGOPT("QA1"),U,2) I X1=""!(X2="") Q ""
S (SDT,X1)=$P(DGN,U),X2=$P(^BDGPAR(1,1),U,7) I X1=""!(X2="") Q ""
D C^%DTC S Y=$O(^DGPM("APTT1",DFN,SDT)) I Y="" Q ""
I Y>X Q ""
S SAV=Y D DD^%DT S ADT=Y
S X1=SAV,X2=SDT D ^%DTC S LMT=X
Q " Admitted on "_ADT_" ("_LMT_" days after surgery)"
;
VISIT() ; -- visit ifn
I DGDS Q $$DSV
N X,Y,Z S Y=(9999999-$P(+DGN,"."))_"."_$E($P(+DGN,".",2),1,4),Z=0 ;maw mod
;N X,Y,Z S Y=(9999999-$P(+DGN,"."))_"."_$P(+DGN,".",2),Z=0 ;maw orig
S X=0 F S X=$O(^AUPNVSIT("AA",DFN,Y,X)) Q:'X D
. Q:'$D(^AUPNVSIT(X,0)) Q:$P(^(0),U,11)=1 Q:$P(^(0),U,7)'="H" S Z=X
Q Z
;
DSV() ;EP -- ds visit ifn
NEW REVDT,V,DATE,Y
S DATE=$P(^ADGDS(DFN,"DS",DGDS,0),U) I DATE="" Q 0
S REVDT=9999999-$P(DATE,"."),REVDT=REVDT_"."_$P(DATE,".",2)
S (Y,V)=0 F Q:Y=1 S V=$O(^AUPNVSIT("AA",DFN,REVDT,V)) Q:'V D
. Q:'$O(^AUPNVPOV("AD",V,0)) ;searhc maw coded visit 4/16/98
. Q:'$O(^AUPNVPRV("AD",V,0)) ;searhc maw coded visit 4/16/98
. I $P(^AUPNVSIT(V,0),U,7)="S" S Y=1
Q $S(Y=1:V,1:0)
;
WRAP(X,DIWL,DIWR,DIWF) ; -- print text fields in word-wrap mode
K ^UTILITY($J,"W") D ^DIWP
S X=0 F S X=$O(^UTILITY($J,"W",DIWL,X)) Q:X="" D
. W:$X>DIWL ! W ?DIWL,^UTILITY($J,"W",DIWL,X,0)
K ^UTILITY($J,"W") Q
ADGCRB5 ; IHS/ADC/PDW/ENM - A SHEET lines 8-11 ; [ 08/25/2004 11:38 AM ]
+1 ;;5.3;PIMS;**1001,1008,1009,1010,1016,1017,1019**;APR 26, 2002;Build 3
+2 ;IHS/ITSC/WAR 8/1/2004 Modified 2nd line to be consistent with version
+3 ; number and IHS patch number. Need to copy this routine and rename
+4 ; it to match current naming scheme for PIMS. Original 2nd line is
+5 ; listed below:
+6 ;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999
+7 ;
+8 ;cmi/anch/maw 12/7/2007 patch 1008 added code set versioning VPOV,VPRC
+9 ;cmi/anch/maw 02/21/2008 PATCH 1009 mods to VPRC requirement 57
+10 ;cmi/anch/maw 04/07/2009 PATCH 1010 mods to check for .05 DIAGNOSIS field before displaying
+11 ;
A ;EP -- driver
+1 DO VSIT
IF 'DGVSDA
QUIT
KILL DGZN
DO H8
DO VPOV
DO H9
DO VPRC
DO H10
DO VINP
QUIT
+2 ;
H8 ; -- sub heading 8
+1 ;W !,DGLIN,!,"26 ICD9 27 Hosp Acq",?24,"28 Established DX",!,DGLIN1 Q
+2 ;ihs/cmi/maw 07/02/2012 PATCH 1016 changed ICD9 to ICD
+3 WRITE !,DGLIN,!,"26 ICD 27 Hosp Acq",?24,"28 Established DX",!,DGLIN1
QUIT
+4 ;
VSIT ; -- visit DGFN
+1 ;IHS/DSD/ENM 10/18/99 A Break Cmd was removed from this line
+2 SET DGVSDA=$$VISIT
+3 IF DGDS
IF 'DGVSDA
WRITE !!,"*** No visit for day surgery entry yet ***"
QUIT
+4 IF 'DGVSDA
WRITE !!,"*** no visit created for this admission - incomplete ***"
+5 QUIT
+6 ;
VPOV ; -- diagnosis
+1 NEW X,Y,Z,DX
SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",DGVSDA,X))
IF 'X
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVPOV(X,0))
QUIT
SET Y=^(0)
IF 'Y!('$DATA(^ICD9(+Y,0)))
QUIT
+3 ;cmi/anch/maw 12/7/2007 csv patch 1008
WRITE !?3,$PIECE($$ICDDX^ICDEX(+Y,0),U,2),?13,$SELECT($PIECE(Y,U,7)=1:"X",1:"")
+4 IF $PIECE(Y,U,9)'=""
SET DGPOVDA=X
SET DGPOVN0=Y
+5 IF '+$PIECE(Y,U,4)!('$DATA(^AUTNPOV(+$PIECE(Y,U,4),0)))
QUIT
+6 ;ihs/cmi/maw 08/10/2014 patch 1017
SET Z=$$GET1^DIQ(9000010.07,X,.04)
IF $LENGTH(Z)<53
WRITE ?27,Z
QUIT
+7 ;S Z=$P(^AUTNPOV(+$P(Y,U,4),0),U) I $L(Z)<53 W ?27,Z Q
+8 DO WRAP(Z,27,79,"")
End DoDot:1
+9 QUIT
+10 ;
H9 ; -- sub heading 9
+1 ;W !,DGLIN1,!,"29 ICD9 30 DX",?18,"31 Op & Selec Procedures"
+2 ;ihs/cmi/maw 07/02/2012 PATCH 1016 changed ICD9 to ICD
+3 WRITE !,DGLIN1,!,"29 ICD 30 DX",?18,"31 Op & Selec Procedures"
+4 WRITE ?55,"32 Post-Op 33 33a Op"
+5 WRITE !?3,"Code",?58,"Infec Date Phy Code",!,DGLIN1
QUIT
+6 ;
VPRC ; -- procedures
+1 NEW DGX,DGY,OPI,OP
SET DGX=0
FOR
SET DGX=$ORDER(^AUPNVPRC("AD",DGVSDA,DGX))
IF 'DGX
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVPRC(DGX,0))
QUIT
SET DGY=^(0)
IF 'DGY!('$DATA(^ICD0(+DGY,0)))
QUIT
+3 ;W !?3,$P(^ICD0(+DGY,0),U)
+4 SET OPI=$$GET1^DIQ(9000010.08,DGX,.01,"I")
+5 SET OP=$$ICDOP^ICDEX(OPI,DT,,"I")
+6 WRITE !?3,$PIECE(OP,U,2)
+7 ;W !?3,$P($$ICDOP^ICDCODE(+DGY),U,2)
+8 ;cmi/maw 2/21/2008 PATCH 1009 requirement 57 updated 4/7/2009
IF $PIECE(DGY,U,5)]""
WRITE ?11,$PIECE($GET(^ICD9($PIECE(DGY,U,5),0)),U)
+9 ; S X=$P(DGY,U,5) I X]"" W ?12,$P($G(^ICD9(X,0)),U) ;dx
+10 ;prov narr
SET X=$PIECE(DGY,U,4)
IF X]""
Begin DoDot:2
+11 IF '+$PIECE(DGY,U,4)!('$DATA(^AUTNPOV(+$PIECE(DGY,U,4),0)))
QUIT
+12 SET X=$PIECE(^AUTNPOV(+$PIECE(DGY,U,4),0),U)
IF $LENGTH(X)<38
WRITE ?21,X
QUIT
+13 DO WRAP(X,21,58,"")
End DoDot:2
+14 WRITE ?60,$SELECT($PIECE(DGY,U,8)="Y":"YES",1:" NO"),?66,$EXTRACT($PIECE(DGY,U,6),4,7)
+15 IF '+$PIECE(DGY,U,11)
QUIT
+16 IF $PIECE(^DD(9000010.06,.01,0),U,2)["200"
Begin DoDot:2
+17 WRITE ?72,$$VAL^XBDIQ1(200,+$PIECE(DGY,U,11),9999999.039)
End DoDot:2
QUIT
+18 WRITE ?72,$$VAL^XBDIQ1(6,+$PIECE(DGY,U,11),9999999.039)
End DoDot:1
+19 QUIT
+20 ;
H10 ; -- sub heading 10
+1 IF DGDS
WRITE !,DGLIN1,!,"34 Post-op Comments",!
QUIT
+2 WRITE !,DGLIN1,!,"34 Discharge Type"
+3 WRITE ?27,"35 Facility Transferred To",?63,"36 Facility Code",!
QUIT
+4 ;
VINP ; -- hospitalization
+1 IF DGDS
DO DSCMTS
QUIT
+2 NEW X,X1,Y
SET X=$ORDER(^AUPNVINP("AD",DGVSDA,0))
IF 'X
QUIT
+3 IF '$DATA(^AUPNVINP(X,0))
QUIT
SET Y=^(0)
+4 ;dsch type
SET X=$PIECE(Y,U,6)
IF X]""
WRITE ?3,$EXTRACT($PIECE(^DG(405.1,X,0),U),1,24)
+5 ; -- facility & code
SET X1=$PIECE(Y,U,9)
IF +X1
Begin DoDot:1
+6 WRITE ?30,$PIECE(@(U_$PIECE(X1,";",2)_+X1_",0)"),U)
+7 IF $PIECE(X1,";",2)'="DIC(4,"
QUIT
+8 WRITE ?66,$PIECE($GET(^AUTTLOC(+X1,0)),U,10)
End DoDot:1
+9 ;
+10 ; -- sub heading 11
+11 WRITE !,DGLIN1,!,"37 Disch Service",?24,"38 Disch Srv Code"
+12 WRITE ?55,"39 # Consults",!
+13 ;
+14 ; -- discharge service & code
SET X1=$PIECE(Y,U,5)
IF +X1
Begin DoDot:1
+15 IF '$DATA(^DIC(45.7,+X1,0))
QUIT
WRITE ?3,$PIECE(^(0),U)
+16 IF '$DATA(^DIC(45.7,X1,9999999))
QUIT
WRITE ?30,$PIECE(^(9999999),U)
End DoDot:1
+17 ;# consults
WRITE ?63,$PIECE(Y,U,8)
+18 QUIT
+19 ;
DSCMTS ; -- day surgery comments
+1 NEW S0,S2,Y,LINE
+2 SET S0=$GET(^ADGDS(DFN,"DS",DGDS,0))
SET S2=$GET(^(2))
SET LINE=""
+3 SET Y=$PIECE(S0,U,7)
IF Y]""
DO DD^%DT
SET LINE=LINE_"Sent to Observation @ "_Y
+4 IF $PIECE(S2,U,5)="Y"
SET LINE=LINE_" UNESCORTED"
+5 SET LINE=LINE_$$ADMDS
+6 SET LINE=LINE_" "_$PIECE(S2,U,6)
WRITE ?2,LINE
+7 QUIT
+8 ;
ADMDS() ; -- admit after ds
+1 NEW SDT,X1,X2,X,Y,SAV,LMT,ADT
+2 ;IHS/ITSC/WAR 6/10/2004 PATCH #1001 fix to address new location of data
+3 ;S (SDT,X1)=$P(DGN,U),X2=$P(DGOPT("QA1"),U,2) I X1=""!(X2="") Q ""
+4 SET (SDT,X1)=$PIECE(DGN,U)
SET X2=$PIECE(^BDGPAR(1,1),U,7)
IF X1=""!(X2="")
QUIT ""
+5 DO C^%DTC
SET Y=$ORDER(^DGPM("APTT1",DFN,SDT))
IF Y=""
QUIT ""
+6 IF Y>X
QUIT ""
+7 SET SAV=Y
DO DD^%DT
SET ADT=Y
+8 SET X1=SAV
SET X2=SDT
DO ^%DTC
SET LMT=X
+9 QUIT " Admitted on "_ADT_" ("_LMT_" days after surgery)"
+10 ;
VISIT() ; -- visit ifn
+1 IF DGDS
QUIT $$DSV
+2 ;maw mod
NEW X,Y,Z
SET Y=(9999999-$PIECE(+DGN,"."))_"."_$EXTRACT($PIECE(+DGN,".",2),1,4)
SET Z=0
+3 ;N X,Y,Z S Y=(9999999-$P(+DGN,"."))_"."_$P(+DGN,".",2),Z=0 ;maw orig
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVSIT("AA",DFN,Y,X))
IF 'X
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVSIT(X,0))
QUIT
IF $PIECE(^(0),U,11)=1
QUIT
IF $PIECE(^(0),U,7)'="H"
QUIT
SET Z=X
End DoDot:1
+6 QUIT Z
+7 ;
DSV() ;EP -- ds visit ifn
+1 NEW REVDT,V,DATE,Y
+2 SET DATE=$PIECE(^ADGDS(DFN,"DS",DGDS,0),U)
IF DATE=""
QUIT 0
+3 SET REVDT=9999999-$PIECE(DATE,".")
SET REVDT=REVDT_"."_$PIECE(DATE,".",2)
+4 SET (Y,V)=0
FOR
IF Y=1
QUIT
SET V=$ORDER(^AUPNVSIT("AA",DFN,REVDT,V))
IF 'V
QUIT
Begin DoDot:1
+5 ;searhc maw coded visit 4/16/98
IF '$ORDER(^AUPNVPOV("AD",V,0))
QUIT
+6 ;searhc maw coded visit 4/16/98
IF '$ORDER(^AUPNVPRV("AD",V,0))
QUIT
+7 IF $PIECE(^AUPNVSIT(V,0),U,7)="S"
SET Y=1
End DoDot:1
+8 QUIT $SELECT(Y=1:V,1:0)
+9 ;
WRAP(X,DIWL,DIWR,DIWF) ; -- print text fields in word-wrap mode
+1 KILL ^UTILITY($JOB,"W")
DO ^DIWP
+2 SET X=0
FOR
SET X=$ORDER(^UTILITY($JOB,"W",DIWL,X))
IF X=""
QUIT
Begin DoDot:1
+3 IF $X>DIWL
WRITE !
WRITE ?DIWL,^UTILITY($JOB,"W",DIWL,X,0)
End DoDot:1
+4 KILL ^UTILITY($JOB,"W")
QUIT
