APCHS11F.m

APCHS11F ; IHS/CMI/LAB - CONTINUATION OF ROUTINES ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;IHS/CMI/LAB - patch 3 for new imm package 1/5/1999

 ; Special HMR routine for ANMC: pneumovax -- to be in next release

 ;

 ; ******************** SURVEILLANCE - HARD CODE ********************

PNUMOVAX ;

 S APCHSDUE=""

 I $D(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK")) S APCHSURP=$O(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK","")) S:$D(^ATXPAT(APCHSURP,11,APCHSPAT)) APCHSRSK=""

 G:APCHSAGE<2 PNUMOVEX ;if under 2 go to exit per Dr. Gollob's message

 S %=$S($E($P(^AUTTLOC(DUZ(2),0),U,10))=3:55,1:65)

 ;alaska area only use 55 all others use 65

 G:(APCHSAGE<%)&('$D(APCHSRSK)) PNUMOVEX

 S APCHSDIS="PNEUMO-VAC"

 S APCHSINT=6*365

 ;S APCHSPVX="PNEUMO-VAC" ;IHS/CMI/LAB - commented out for new imm package

 ;S APCHSPVX=$O(^AUTTIMM("B","PNEUMO-VAC","")) ;IHS/CMI/LAB - commented out for new imm package

 ;S:'APCHSPVX APCHSPVX=$O(^AUTTIMM("C",19,"")) ;IHS/CMI/LAB - commented out for new imm package

 S APCHSPVX=$S($$BI^APCHS11C:$O(^AUTTIMM("C",33,"")),1:$O(^AUTTIMM("C",19,""))) ;IHS/CMI/LAB - new line for imm package

 I 'APCHSPVX D  G DSPLY

 . S (APCHSDAT,APCHSDUE)=""

 . S APCHSTEX(1)="Pneumococcal immunization appears indicated,"

 . S APCHSTEX(2)=" but PNEUMO-VAC cannot be located in the"

 . S APCHSTEX(3)=" immunization type file, so the patient's"

 . S APCHSTEX(4)=" history cannot be evaluated."

 S APCHSIVD=$O(^AUPNVIMM("AA",APCHSPAT,APCHSPVX,""))

 I 'APCHSIVD S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" G DSPLY

GETDATE ;

 D COMPARE^APCHS11,GETDATE^APCHS11

 I APCHSDUE]"",$E($P(^AUTTLOC(DUZ(2),0),U,10))'=3 S APCHSDUE=""

DSPLY ;

 I APCHSDUE["DUE" S APCHSEXD=$S($$BI^APCHS11C:$O(^AUTTIMM("C",33,0)),1:$O(^AUTTIMM("C",19,0))),APCHSDF1=9999999.14 D REFDF^APCHS11

 D DISPLAY^APCHS11

PNUMOVEX ;

 K APCHSURP,APCHSRSK,APCHSPVX,APCHSTEX

 Q

 ;

DOMV ;

 Q:APCHSAGE<14  ;IHS/CMI/LAB 12/16/97

 ;

 S APCHSCAT=$O(^AUTTHF("B","DOMESTIC VIOLENCE",""))

 Q:'APCHSCAT

 S APCHSDIS="DOMESTIC VIOLENCE SCRN"

 S APCHSINT=365

 D HFACTOR^APCHS11C

DOMVX ;

 Q

 ;

REHAB ; EP - called from reminder

 Q:APCHSAGE<18

 S APCHSCAT=$O(^AUTTHF("B","REHABILITATION/FUNCTIONAL SCRN",0))

 Q:'APCHSCAT

 S APCHSDIS="REHAB/FUNCTIONAL SCRN"

 S APCHSINT=365

 D HFACTOR^APCHS11C

REHABX ;

 Q

APCHS11F  ; IHS/CMI/LAB - CONTINUATION OF ROUTINES ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;IHS/CMI/LAB - patch 3 for new imm package 1/5/1999

 +3       ; Special HMR routine for ANMC: pneumovax -- to be in next release

 +4       ;

 +5       ; ******************** SURVEILLANCE - HARD CODE ********************

PNUMOVAX  ;

 +1        SET APCHSDUE=""

 +2        IF $DATA(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK"))

               SET APCHSURP=$ORDER(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK",""))

               IF $DATA(^ATXPAT(APCHSURP,11,APCHSPAT))

                   SET APCHSRSK=""

 +3       ;if under 2 go to exit per Dr. Gollob's message

           IF APCHSAGE<2

               GOTO PNUMOVEX

 +4        SET %=$SELECT($EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10))=3:55,1:65)

 +5       ;alaska area only use 55 all others use 65

 +6        IF (APCHSAGE<%)&('$DATA(APCHSRSK))

               GOTO PNUMOVEX

 +7        SET APCHSDIS="PNEUMO-VAC"

 +8        SET APCHSINT=6*365

 +9       ;S APCHSPVX="PNEUMO-VAC" ;IHS/CMI/LAB - commented out for new imm package

 +10      ;S APCHSPVX=$O(^AUTTIMM("B","PNEUMO-VAC","")) ;IHS/CMI/LAB - commented out for new imm package

 +11      ;S:'APCHSPVX APCHSPVX=$O(^AUTTIMM("C",19,"")) ;IHS/CMI/LAB - commented out for new imm package

 +12      ;IHS/CMI/LAB - new line for imm package

           SET APCHSPVX=$SELECT($$BI^APCHS11C:$O(^AUTTIMM("C",33,"")),1:$ORDER(^AUTTIMM("C",19,"")))

 +13       IF 'APCHSPVX

               Begin DoDot:1

 +14               SET (APCHSDAT,APCHSDUE)=""

 +15               SET APCHSTEX(1)="Pneumococcal immunization appears indicated,"

 +16               SET APCHSTEX(2)=" but PNEUMO-VAC cannot be located in the"

 +17               SET APCHSTEX(3)=" immunization type file, so the patient's"

 +18               SET APCHSTEX(4)=" history cannot be evaluated."

               End DoDot:1

               GOTO DSPLY

 +19       SET APCHSIVD=$ORDER(^AUPNVIMM("AA",APCHSPAT,APCHSPVX,""))

 +20       IF 'APCHSIVD

               SET APCHSDUE="MAY BE DUE NOW"

               SET APCHSDAT=""

               GOTO DSPLY

GETDATE   ;

 +1        DO COMPARE^APCHS11

           DO GETDATE^APCHS11

 +2        IF APCHSDUE]""

               IF $EXTRACT($PIECE(^AUTTLOC(DUZ(2),0),U,10))'=3

                   SET APCHSDUE=""

DSPLY     ;

 +1        IF APCHSDUE["DUE"

               SET APCHSEXD=$SELECT($$BI^APCHS11C:$O(^AUTTIMM("C",33,0)),1:$ORDER(^AUTTIMM("C",19,0)))

               SET APCHSDF1=9999999.14

               DO REFDF^APCHS11

 +2        DO DISPLAY^APCHS11

PNUMOVEX  ;

 +1        KILL APCHSURP,APCHSRSK,APCHSPVX,APCHSTEX

 +2        QUIT 

 +3       ;

DOMV      ;

 +1       ;IHS/CMI/LAB 12/16/97

           IF APCHSAGE<14

               QUIT 

 +2       ;

 +3        SET APCHSCAT=$ORDER(^AUTTHF("B","DOMESTIC VIOLENCE",""))

 +4        IF 'APCHSCAT

               QUIT 

 +5        SET APCHSDIS="DOMESTIC VIOLENCE SCRN"

 +6        SET APCHSINT=365

 +7        DO HFACTOR^APCHS11C

DOMVX     ;

 +1        QUIT 

 +2       ;

REHAB     ; EP - called from reminder

 +1        IF APCHSAGE<18

               QUIT 

 +2        SET APCHSCAT=$ORDER(^AUTTHF("B","REHABILITATION/FUNCTIONAL SCRN",0))

 +3        IF 'APCHSCAT

               QUIT 

 +4        SET APCHSDIS="REHAB/FUNCTIONAL SCRN"

 +5        SET APCHSINT=365

 +6        DO HFACTOR^APCHS11C

REHABX    ;

 +1        QUIT