APCLAP22.m

APCLAP22 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;

 ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58

 ;

 ;cmi/anch/maw 9/7/2007 code set versioning in DX

 ;

DATE ;EP

 S APCLDATE=$P(APCLODAT,".")

 S X=APCLDATE D H^%DTC S APCLSRT2=$P("SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",";",%Y+1) I APCLSRT2="" S APCLSRT2="UNKNOWN"

 Q

CLIN ;EP

 S APCLCLIN=$P(APCLVREC,U,8) I APCLCLIN="" S APCLCLIN="NO CLINIC ENTERED",APCLSRT2="99999" Q

CLIN1 S APCLSRT2=$P(^DIC(40.7,APCLCLIN,0),U,2),APCLCLIN=$P(^DIC(40.7,APCLCLIN,0),U)

 Q

SC ;EP

 K ^UTILITY("DIQ1",$J)

 K DIQ,DIC,DA,DR

 S DIC="^AUPNVSIT(",DR=".07",DA=APCLVDFN,DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR,DIQ

 S APCLCAT=^UTILITY("DIQ1",$J,9000010,APCLVDFN,.07,"E")

 S APCLSRT2=$P(APCLVREC,U,7)

 K ^UTILITY("DIQ1",$J)

 Q

DX ;EP

 S APCLPPOV=$O(^AUPNVPOV("AD",APCLVDFN,""))

 I APCLPPOV="" S APCLDX="NO DIAGNOSIS ENTERED",APCLSRT2="-----" Q

 ;cmi/anch/maw 9/7/2007 mods for code set versioning

 N APCLVDT

 S APCLVDT=+$P($G(^AUPNVSIT(APCLVDFN,0)),".")

 ;cmi/anch/maw 9/7/2007 end of mods

 ;S APCLSRT2=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U)

 I $P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPPOV,0),U),APCLVDT),U,1)=-1 S APCLSRT2="?????",APCLDX=$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPPOV,0),U),APCLVDT),U,2) Q

 S APCLSRT2=$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPPOV,0),U),APCLVDT),U,2)

 ;S APCLDX=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U,3)

 S APCLDX=$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPPOV,0),U),APCLVDT),U,4)

 Q

APCLAP22  ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;

 +1       ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58

 +2       ;

 +3       ;cmi/anch/maw 9/7/2007 code set versioning in DX

 +4       ;

DATE      ;EP

 +1        SET APCLDATE=$PIECE(APCLODAT,".")

 +2        SET X=APCLDATE

           DO H^%DTC

           SET APCLSRT2=$PIECE("SUNDAY;MONDAY;TUESDAY;WEDNESDAY;THURSDAY;FRIDAY;SATURDAY",";",%Y+1)

           IF APCLSRT2=""

               SET APCLSRT2="UNKNOWN"

 +3        QUIT 

CLIN      ;EP

 +1        SET APCLCLIN=$PIECE(APCLVREC,U,8)

           IF APCLCLIN=""

               SET APCLCLIN="NO CLINIC ENTERED"

               SET APCLSRT2="99999"

               QUIT 

CLIN1      SET APCLSRT2=$PIECE(^DIC(40.7,APCLCLIN,0),U,2)

           SET APCLCLIN=$PIECE(^DIC(40.7,APCLCLIN,0),U)

 +1        QUIT 

SC        ;EP

 +1        KILL ^UTILITY("DIQ1",$JOB)

 +2        KILL DIQ,DIC,DA,DR

 +3        SET DIC="^AUPNVSIT("

           SET DR=".07"

           SET DA=APCLVDFN

           SET DIQ(0)="E"

           DO EN^DIQ1

           KILL DIC,DA,DR,DIQ

 +4        SET APCLCAT=^UTILITY("DIQ1",$JOB,9000010,APCLVDFN,.07,"E")

 +5        SET APCLSRT2=$PIECE(APCLVREC,U,7)

 +6        KILL ^UTILITY("DIQ1",$JOB)

 +7        QUIT 

DX        ;EP

 +1        SET APCLPPOV=$ORDER(^AUPNVPOV("AD",APCLVDFN,""))

 +2        IF APCLPPOV=""

               SET APCLDX="NO DIAGNOSIS ENTERED"

               SET APCLSRT2="-----"

               QUIT 

 +3       ;cmi/anch/maw 9/7/2007 mods for code set versioning

 +4        NEW APCLVDT

 +5        SET APCLVDT=+$PIECE($GET(^AUPNVSIT(APCLVDFN,0)),".")

 +6       ;cmi/anch/maw 9/7/2007 end of mods

 +7       ;S APCLSRT2=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U)

 +8        IF $PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCLPPOV,0),U),APCLVDT),U,1)=-1

               SET APCLSRT2="?????"

               SET APCLDX=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCLPPOV,0),U),APCLVDT),U,2)

               QUIT 

 +9        SET APCLSRT2=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCLPPOV,0),U),APCLVDT),U,2)

 +10      ;S APCLDX=$P(^ICD9($P(^AUPNVPOV(APCLPPOV,0),U),0),U,3)

 +11       SET APCLDX=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCLPPOV,0),U),APCLVDT),U,4)

 +12       QUIT