ADGPCAC3.m

ADGPCAC3 ; IHS/ADC/PDW/ENM - ADT/PCC DATA ENTRY-PROCEDURE ; [ 03/25/1999  11:48 AM ]

 ;;5.3;ADMISSION/DISCHARGE/TRANSFER;**1008**;MAR 25, 1999

 ;

 ;cmi/anch/maw 12/7/2007 patch 1008 added code set versioning DX,PRC

 ;

A ; -- driver

 D L3 Q:$D(DIRUT)

 D ^ADGPCAC4 Q

 ;

L3 ; -- loop v procedure

 N IFN,N

 Q:'$D(^AUPNVPRC("AD",DGVI))

 W @IOF," (3) Procedure"

 S IFN=0 F  S IFN=$O(^AUPNVPRC("AD",DGVI,IFN)) Q:'IFN  D 3 Q:$D(DIRUT)

 Q:$D(DIRUT)  D Q Q

 ;

3 ; -- display procedure/operation info

 Q:'$D(^AUPNVPRC(IFN,0))  S N=^(0)

 W !!?12,"Procedure: ",$$PRC,!?12,"Narrative: ",$$NAR

 W !?12,"Diagnosis: ",$$DX,?54,"Date: ",$$DT

 W !?6,"Principle Proc.? ",$$PP,?49,"Infection? ",$$INF

 W !?3,"Operating Provider: ",$$OPP

 I $P(N,U,14) W !?4,"Anesthesia Admin?: YES",?45,"ASA-PS Class: ",$$ASA

 ; -- form feed?

 W ! Q:($Y+4)'>IOSL  K DIR S DIR(0)="E" D ^DIR K DIR,X W @IOF Q

 ;

Q ; -- cleanup

 I $Y>4 K DIR W ! S DIR(0)="E" D ^DIR K DIR,X W @IOF

 Q

 ;

PRC() ; -- procedure

 ;Q $P($G(^ICD0(+N,0)),U)_"  "_$E($P($G(^ICD0(+N,0)),U,4),1,44)

 Q $P($$ICDOP^ICDCODE(+N),U,2)_"  "_$E($P($G(^ICD0(+N,0)),U,4),1,44)

 ;

NAR() ; -- narrative

 Q $P($G(^AUTNPOV(+$P(N,U,4),0)),U)

 ;

DX() ; -- diagnosis

 ;Q $P($G(^ICD9(+$P(N,U,5),0)),U,3)

 Q $P($$ICDDX^ICDCODE(+$P(N,U,5)),U,4)

 ;

DT() ; -- date

 N X S X=$P(N,U,6) Q:'X ""  Q $E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)

 ;

PP() ; -- principle proc

 N Y S Y=$P(N,U,7) S C=$P(^DD(9000010.08,.07,0),U,2) D Y^DIQ Q Y

 ;

INF() ; -- infection

 N Y S Y=$P(N,U,8) S C=$P(^DD(9000010.08,.08,0),U,2) D Y^DIQ Q Y

 ;

OPP() ; -- operating provider

 N Y S Y=$P(N,U,11) S C=$P(^DD(9000010.08,.11,0),U,2) D Y^DIQ Q Y

 ;

ASA() ; -- ASA-PS class

 N Y S Y=$P(N,U,15) S C=$P(^DD(9000010.08,.15,0),U,2) D Y^DIQ Q Y

ADGPCAC3  ; IHS/ADC/PDW/ENM - ADT/PCC DATA ENTRY-PROCEDURE ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.3;ADMISSION/DISCHARGE/TRANSFER;**1008**;MAR 25, 1999

 +2       ;

 +3       ;cmi/anch/maw 12/7/2007 patch 1008 added code set versioning DX,PRC

 +4       ;

A         ; -- driver

 +1        DO L3

           IF $DATA(DIRUT)

               QUIT 

 +2        DO ^ADGPCAC4

           QUIT 

 +3       ;

L3        ; -- loop v procedure

 +1        NEW IFN,N

 +2        IF '$DATA(^AUPNVPRC("AD",DGVI))

               QUIT 

 +3        WRITE @IOF," (3) Procedure"

 +4        SET IFN=0

           FOR 

               SET IFN=$ORDER(^AUPNVPRC("AD",DGVI,IFN))

               IF 'IFN

                   QUIT 

               DO 3

               IF $DATA(DIRUT)

                   QUIT 

 +5        IF $DATA(DIRUT)

               QUIT 

           DO Q

           QUIT 

 +6       ;

3         ; -- display procedure/operation info

 +1        IF '$DATA(^AUPNVPRC(IFN,0))

               QUIT 

           SET N=^(0)

 +2        WRITE !!?12,"Procedure: ",$$PRC,!?12,"Narrative: ",$$NAR

 +3        WRITE !?12,"Diagnosis: ",$$DX,?54,"Date: ",$$DT

 +4        WRITE !?6,"Principle Proc.? ",$$PP,?49,"Infection? ",$$INF

 +5        WRITE !?3,"Operating Provider: ",$$OPP

 +6        IF $PIECE(N,U,14)

               WRITE !?4,"Anesthesia Admin?: YES",?45,"ASA-PS Class: ",$$ASA

 +7       ; -- form feed?

 +8        WRITE !

           IF ($Y+4)'>IOSL

               QUIT 

           KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR,X

           WRITE @IOF

           QUIT 

 +9       ;

Q         ; -- cleanup

 +1        IF $Y>4

               KILL DIR

               WRITE !

               SET DIR(0)="E"

               DO ^DIR

               KILL DIR,X

               WRITE @IOF

 +2        QUIT 

 +3       ;

PRC()     ; -- procedure

 +1       ;Q $P($G(^ICD0(+N,0)),U)_"  "_$E($P($G(^ICD0(+N,0)),U,4),1,44)

 +2        QUIT $PIECE($$ICDOP^ICDCODE(+N),U,2)_"  "_$EXTRACT($PIECE($GET(^ICD0(+N,0)),U,4),1,44)

 +3       ;

NAR()     ; -- narrative

 +1        QUIT $PIECE($GET(^AUTNPOV(+$PIECE(N,U,4),0)),U)

 +2       ;

DX()      ; -- diagnosis

 +1       ;Q $P($G(^ICD9(+$P(N,U,5),0)),U,3)

 +2        QUIT $PIECE($$ICDDX^ICDCODE(+$PIECE(N,U,5)),U,4)

 +3       ;

DT()      ; -- date

 +1        NEW X

           SET X=$PIECE(N,U,6)

           IF 'X

               QUIT ""

           QUIT $EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)

 +2       ;

PP()      ; -- principle proc

 +1        NEW Y

           SET Y=$PIECE(N,U,7)

           SET C=$PIECE(^DD(9000010.08,.07,0),U,2)

           DO Y^DIQ

           QUIT Y

 +2       ;

INF()     ; -- infection

 +1        NEW Y

           SET Y=$PIECE(N,U,8)

           SET C=$PIECE(^DD(9000010.08,.08,0),U,2)

           DO Y^DIQ

           QUIT Y

 +2       ;

OPP()     ; -- operating provider

 +1        NEW Y

           SET Y=$PIECE(N,U,11)

           SET C=$PIECE(^DD(9000010.08,.11,0),U,2)

           DO Y^DIQ

           QUIT Y

 +2       ;

ASA()     ; -- ASA-PS class

 +1        NEW Y

           SET Y=$PIECE(N,U,15)

           SET C=$PIECE(^DD(9000010.08,.15,0),U,2)

           DO Y^DIQ

           QUIT Y