ACMLCMS.m

ACMLCMS ; IHS/TUCSON/TMJ - ENTRY TO SET AND DISPLAY CLIENT DATA ; [ 01/03/06  2:03 PM ]

 ;;2.0;ACM CASE MANAGEMENT SYSTEM;**2,5,6**;JAN 10, 1996

 ;PATCH #6 FIXES INSURANCE HEADER DISPLAY AND FORMAT PROBLEMS

 ;EP;ENTRY POINT TO SET AND DISPLAY CLIENT DATA

LCMS D INIT,VARS

 Q

 ;

INIT ;S ACMDOB=$P(^DPT(ACMPTNO,0),U,3),(Y,X2)=ACMDOB,X1=DT

 S ACMDOB=$P(^DPT(ACMPTNO,0),U,3),(Y,X2)=ACMDOB,X1=DT,ACMPHONE=$P($G(^(.13)),U) ;IHS/CIM/THL PATCH 5

 D ^%DTC

 X ^DD("DD")

 S ACMDOB=Y

 I X>365 S ACMAGE=(X\365.25)_" YRS"

 I (X>30)&(X<366) S ACMAGE=(X\30.4)_" MOS"

 I X<31 S ACMAGE=X_" (DYS)"

 Q

 ;

VARS I $D(DUZ(2))#2,DUZ(2) S ACMSRT=$S($D(^AUPNPAT(ACMPTNO,41,DUZ(2),0)):$P(^(0),U,2),1:"<NONE>")

 S (ACMSTAT,ACMSEV,ACMPC,ACMINIT,ACMWHER,ACMCOMM,ACMPG)="NOT STATED",(ACMPRV,ACMMGR,ACMPHN)="NONE ASSIGNED"

 S ACMDT="^ACM(41,"_ACMRGDFN_",""DT"")"

 I '$D(@ACMDT) S @ACMDT="A"

 S ACMDT=@ACMDT,ACMSTAT=$S($P(ACMDT,U)'="":$P(ACMDT,U),1:"NOT STATED"),ACMMGR=$S($P(ACMDT,U,6)'="":$P(ACMDT,U,6),1:"NONE ASSIGNED")

 S:ACMMGR'="NONE ASSIGNED" ACMMGR=$S($D(^VA(200,ACMMGR,0)):$P(^(0),U),1:"NONE ASSIGNED")

 S ACMPHN=$S($P(ACMDT,U,7)'="":$P(ACMDT,U,7),1:"NONE ASSIGNED")

 S:ACMPHN'="NONE ASSIGNED" ACMPHN=$S($D(^VA(200,ACMPHN,0)):$P(^(0),U),1:"NONE ASSIGNED")

 S ACMSEV=$S($P(ACMDT,U,5)'="":$P(ACMDT,U,5),1:"NOT STATED")

 I $P(ACMDT,U,4)'="" S ACMINIT=$P(ACMDT,U,4) S Y=ACMINIT X ^DD("DD") S ACMINIT=Y

 S ACMWHER=$S($P(ACMDT,U,10):$P(ACMDT,U,10),1:"NOT STATED")

 S:ACMWHER'="NOT STATED" ACMWHER=$S($D(^AUTTLOC(ACMWHER,0)):$P(^(0),U,2),1:"NOT STATED")

 S ACMPG=$S($P(ACMDT,U,13)'="":$P(ACMDT,U,13),1:"NOT STATED"),ACMPC=$S($P(ACMDT,U,14)'="":$P(ACMDT,U,14),1:"NOT STATED"),ACMPRV=$S($P(ACMDT,U,15)'="":$P(ACMDT,U,15),1:"NONE ASSIGNED")

 S:ACMPRV'="NONE ASSIGNED" ACMPRV=$S($D(^VA(200,ACMPRV,0)):$P(^(0),U),1:"NONE ASSIGNED")

 S ACMCOMM=$S($D(^AUPNPAT(ACMPTNO,11)):$P(^(11),U,18),1:"")

 S:ACMCOMM="" ACMCOMM="NOT STATED"

 K ACMDT

 Q

ACMPT ;EP;TO DISPLAY PATIENT INFO

 W:'$D(ACMPAGE) !?7,"CHART: ",ACMSRT

 W:$D(ACMPAGE) !  ;IHS/ANMC/LJF 11/5/99 put PCP on separate line if rpt

 W ?35,"PRIMARY CARE PROVIDER: ",$$VAL^XBDIQ1(9000001,ACMPTNO,.14)  ;IHS/ANMC/LJF 11/5/99

 W !?9,"DOB: ",?14,ACMDOB,?53,"AGE: ",ACMAGE

 W !?5,"CONTACT: ",?14,$S(ACMPG'="":ACMPG,1:"NOT LISTED"),?47,"COMMUNITY: ",ACMCOMM ;IHS/CIM/THL PATCH 5

 W !?46,"HOME PHONE: ",$G(ACMPHONE) ;IHS/CIM/THL PATCH 5

 N APCHSPAT,APCHSCKP,APCHSNPG

 S APCHSPAT=ACMPTNO

 S APCHSCKP=""

 S APCHSNPG=1

 S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"

 S ACMINS=0 ;IHS/CMI/TMJ PATCH #6

 I $D(^AUPNMCD("B",ACMPTNO)) S ACMINS=1

 I $D(^AUPNMCR(ACMPTNO)) S ACMINS=1

 I $D(^AUPNPRVT(ACMPTNO)) S ACMINS=1

 I $D(^AUPNRRE(ACMPTNO)) S ACMINS=1

 I ACMINS=1 W !,"**************************  INSURANCE INFORMATION  ***************************",!

 D INS^APCHS5

 W !  ;IHS/ANMC/LJF 11/5/99 separate editable from uneditable fields

 W "     ***********************  PATIENT INFORMATION  *************************",! ;IHS/CMI/TMJ PATCH #6

 W ?6,"STATUS: ",$S(ACMSTAT="A":"ACTIVE",ACMSTAT="I":"INACTIVE",ACMSTAT="T":"TRANSIENT",ACMSTAT="U":"UNREVIEWED",ACMSTAT="D":"DECEASED",ACMSTAT="N":"NON-IHS",1:"NOT STATED")

 ;W ?44,"CASE PRIORIT: ",?14,$S(ACMSEV="L":"LOW",ACMSEV="M":"MEDIUM",ACMSEV="H":"HIGH",ACMSEV="C":"CRITICAL",1:"NOT STATED"),!,"PRIMARY PRVD: ",?14,ACMPRV

 W ?44,"CASE PRIORIT: ",?58,$S(ACMSEV="L":"LOW",ACMSEV="M":"MEDIUM",ACMSEV="H":"HIGH",ACMSEV="C":"CRITICAL",1:"NOT STATED"),!,?6,"REGISTER PRV: ",?14,ACMPRV  ;IHS/ANMC/LJF 11/5/99

 W ?46,"INIT ENTRY: ",$S($D(ACMINIT):ACMINIT,1:"NOT STATED"),!,?6,"CASE MANAGER: ",?14,ACMMGR,?46,"WHERE FLWD: ",ACMWHER

 W !,?6,"PUB HLTH NRS:",?14,$S($D(ACMPHN):ACMPHN,1:"NONE ASSIGNED")

 I $D(ACMPAGE)&(IOST["P-") S DR="12////"_DT,DIE="^ACM(41,",DA=ACMRGDFN D ^DIE

 Q

ACMLCMS   ; IHS/TUCSON/TMJ - ENTRY TO SET AND DISPLAY CLIENT DATA ; [ 01/03/06  2:03 PM ]

 +1       ;;2.0;ACM CASE MANAGEMENT SYSTEM;**2,5,6**;JAN 10, 1996

 +2       ;PATCH #6 FIXES INSURANCE HEADER DISPLAY AND FORMAT PROBLEMS

 +3       ;EP;ENTRY POINT TO SET AND DISPLAY CLIENT DATA

LCMS       DO INIT

           DO VARS

 +1        QUIT 

 +2       ;

INIT      ;S ACMDOB=$P(^DPT(ACMPTNO,0),U,3),(Y,X2)=ACMDOB,X1=DT

 +1       ;IHS/CIM/THL PATCH 5

           SET ACMDOB=$PIECE(^DPT(ACMPTNO,0),U,3)

           SET (Y,X2)=ACMDOB

           SET X1=DT

           SET ACMPHONE=$PIECE($GET(^(.13)),U)

 +2        DO ^%DTC

 +3        XECUTE ^DD("DD")

 +4        SET ACMDOB=Y

 +5        IF X>365

               SET ACMAGE=(X\365.25)_" YRS"

 +6        IF (X>30)&(X<366)

               SET ACMAGE=(X\30.4)_" MOS"

 +7        IF X<31

               SET ACMAGE=X_" (DYS)"

 +8        QUIT 

 +9       ;

VARS       IF $DATA(DUZ(2))#2

               IF DUZ(2)

                   SET ACMSRT=$SELECT($DATA(^AUPNPAT(ACMPTNO,41,DUZ(2),0)):$PIECE(^(0),U,2),1:"<NONE>")

 +1        SET (ACMSTAT,ACMSEV,ACMPC,ACMINIT,ACMWHER,ACMCOMM,ACMPG)="NOT STATED"

           SET (ACMPRV,ACMMGR,ACMPHN)="NONE ASSIGNED"

 +2        SET ACMDT="^ACM(41,"_ACMRGDFN_",""DT"")"

 +3        IF '$DATA(@ACMDT)

               SET @ACMDT="A"

 +4        SET ACMDT=@ACMDT

           SET ACMSTAT=$SELECT($PIECE(ACMDT,U)'="":$PIECE(ACMDT,U),1:"NOT STATED")

           SET ACMMGR=$SELECT($PIECE(ACMDT,U,6)'="":$PIECE(ACMDT,U,6),1:"NONE ASSIGNED")

 +5        IF ACMMGR'="NONE ASSIGNED"

               SET ACMMGR=$SELECT($DATA(^VA(200,ACMMGR,0)):$PIECE(^(0),U),1:"NONE ASSIGNED")

 +6        SET ACMPHN=$SELECT($PIECE(ACMDT,U,7)'="":$PIECE(ACMDT,U,7),1:"NONE ASSIGNED")

 +7        IF ACMPHN'="NONE ASSIGNED"

               SET ACMPHN=$SELECT($DATA(^VA(200,ACMPHN,0)):$PIECE(^(0),U),1:"NONE ASSIGNED")

 +8        SET ACMSEV=$SELECT($PIECE(ACMDT,U,5)'="":$PIECE(ACMDT,U,5),1:"NOT STATED")

 +9        IF $PIECE(ACMDT,U,4)'=""

               SET ACMINIT=$PIECE(ACMDT,U,4)

               SET Y=ACMINIT

               XECUTE ^DD("DD")

               SET ACMINIT=Y

 +10       SET ACMWHER=$SELECT($PIECE(ACMDT,U,10):$PIECE(ACMDT,U,10),1:"NOT STATED")

 +11       IF ACMWHER'="NOT STATED"

               SET ACMWHER=$SELECT($DATA(^AUTTLOC(ACMWHER,0)):$PIECE(^(0),U,2),1:"NOT STATED")

 +12       SET ACMPG=$SELECT($PIECE(ACMDT,U,13)'="":$PIECE(ACMDT,U,13),1:"NOT STATED")

           SET ACMPC=$SELECT($PIECE(ACMDT,U,14)'="":$PIECE(ACMDT,U,14),1:"NOT STATED")

           SET ACMPRV=$SELECT($PIECE(ACMDT,U,15)'="":$PIECE(ACMDT,U,15),1:"NONE ASSIGNED")

 +13       IF ACMPRV'="NONE ASSIGNED"

               SET ACMPRV=$SELECT($DATA(^VA(200,ACMPRV,0)):$PIECE(^(0),U),1:"NONE ASSIGNED")

 +14       SET ACMCOMM=$SELECT($DATA(^AUPNPAT(ACMPTNO,11)):$PIECE(^(11),U,18),1:"")

 +15       IF ACMCOMM=""

               SET ACMCOMM="NOT STATED"

 +16       KILL ACMDT

 +17       QUIT 

ACMPT     ;EP;TO DISPLAY PATIENT INFO

 +1        IF '$DATA(ACMPAGE)

               WRITE !?7,"CHART: ",ACMSRT

 +2       ;IHS/ANMC/LJF 11/5/99 put PCP on separate line if rpt

           IF $DATA(ACMPAGE)

               WRITE !

 +3       ;IHS/ANMC/LJF 11/5/99

           WRITE ?35,"PRIMARY CARE PROVIDER: ",$$VAL^XBDIQ1(9000001,ACMPTNO,.14)

 +4        WRITE !?9,"DOB: ",?14,ACMDOB,?53,"AGE: ",ACMAGE

 +5       ;IHS/CIM/THL PATCH 5

           WRITE !?5,"CONTACT: ",?14,$SELECT(ACMPG'="":ACMPG,1:"NOT LISTED"),?47,"COMMUNITY: ",ACMCOMM

 +6       ;IHS/CIM/THL PATCH 5

           WRITE !?46,"HOME PHONE: ",$GET(ACMPHONE)

 +7        NEW APCHSPAT,APCHSCKP,APCHSNPG

 +8        SET APCHSPAT=ACMPTNO

 +9        SET APCHSCKP=""

 +10       SET APCHSNPG=1

 +11       SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"

 +12      ;IHS/CMI/TMJ PATCH #6

           SET ACMINS=0

 +13       IF $DATA(^AUPNMCD("B",ACMPTNO))

               SET ACMINS=1

 +14       IF $DATA(^AUPNMCR(ACMPTNO))

               SET ACMINS=1

 +15       IF $DATA(^AUPNPRVT(ACMPTNO))

               SET ACMINS=1

 +16       IF $DATA(^AUPNRRE(ACMPTNO))

               SET ACMINS=1

 +17       IF ACMINS=1

               WRITE !,"**************************  INSURANCE INFORMATION  ***************************",!

 +18       DO INS^APCHS5

 +19      ;IHS/ANMC/LJF 11/5/99 separate editable from uneditable fields

           WRITE !

 +20      ;IHS/CMI/TMJ PATCH #6

           WRITE "     ***********************  PATIENT INFORMATION  *************************",!

 +21       WRITE ?6,"STATUS: ",$SELECT(ACMSTAT="A":"ACTIVE",ACMSTAT="I":"INACTIVE",ACMSTAT="T":"TRANSIENT",ACMSTAT="U":"UNREVIEWED",ACMSTAT="D":"DECEASED",ACMSTAT="N":"NON-IHS",1:"NOT STATED")

 +22      ;W ?44,"CASE PRIORIT: ",?14,$S(ACMSEV="L":"LOW",ACMSEV="M":"MEDIUM",ACMSEV="H":"HIGH",ACMSEV="C":"CRITICAL",1:"NOT STATED"),!,"PRIMARY PRVD: ",?14,ACMPRV

 +23      ;IHS/ANMC/LJF 11/5/99

           WRITE ?44,"CASE PRIORIT: ",?58,$SELECT(ACMSEV="L":"LOW",ACMSEV="M":"MEDIUM",ACMSEV="H":"HIGH",ACMSEV="C":"CRITICAL",1:"NOT STATED"),!,?6,"REGISTER PRV: ",?14,ACMPRV

 +24       WRITE ?46,"INIT ENTRY: ",$SELECT($DATA(ACMINIT):ACMINIT,1:"NOT STATED"),!,?6,"CASE MANAGER: ",?14,ACMMGR,?46,"WHERE FLWD: ",ACMWHER

 +25       WRITE !,?6,"PUB HLTH NRS:",?14,$SELECT($DATA(ACMPHN):ACMPHN,1:"NONE ASSIGNED")

 +26       IF $DATA(ACMPAGE)&(IOST["P-")

               SET DR="12////"_DT

               SET DIE="^ACM(41,"

               SET DA=ACMRGDFN

               DO ^DIE

 +27       QUIT