ADGCRB5.m

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