Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHPOST

AMHPOST.m

Go to the documentation of this file. 
  1. AMHPOST ; IHS/CMI/LAB - POST INIT BH ;  
  1.  ;;3.0;IHS BEHAVIORAL HEALTH;;JAN 27, 2003
  1.  ;re-index all cross references on Designated provider fields
  1.  ;
  1. ENV ;EP 
  1.  I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
  1.  Q
  1.  ;
  1. PRE ;
  1.  ;REMOVE IDENTIFIER NODES FOR FILEMAN 22
  1.  K ^DD(9002011.01,0,"ID")
  1.  K ^DD(9002011.02,0,"ID")
  1.  K ^DD(9002011.03,0,"ID")
  1.  K ^DD(9002011.04,0,"ID")
  1.  K ^DD(9002011.05,0,"ID")
  1.  S DIK="^DD(9002012.2,",DA=.04,DA(1)=9002012.2 D ^DIK
  1.  D ^AMHPREI
  1.  D ^AMHPREI1
  1.  D ^AMHPREI2
  1.  F DA=1:1:200 S DIK="^AMHSORT(" D ^DIK
  1.  S DA=$O(^AMHTSET("B","TELE-MENTAL HEALTH",0))
  1.  I DA S DIE="^AMHTSET(",DR=".02///15" D ^DIE K DA,DIE,DR
  1.  S DA=$O(^AMHTSET("B","RESIDENTIAL/DAY PROGRAM",0))
  1.  I DA S DIE="^AMHTSET(",DR=".01///RESIDENTIAL" D ^DIE
  1.  S DA=$O(^AMHTSET("B","OUTPATIENT CLINIC",0))
  1.  I DA S DIE="^AMHTSET(",DR=".01///OUTPATIENT" D ^DIE
  1.  S DA=$O(^DIC(19,"B","AMH DE ACT RECORD LOG",0)) I DA S DIK="^DIC(19," D ^DIK
  1.  S DA=$O(^DIC(19,"B","AMH E ADD CASE TRACKING",0)) I DA S DIK="^DIC(19," D ^DIK
  1.  S DA=$O(^DIC(19,"B","AMH DE PATIENT RELATED",0)) I DA S DIK="^DIC(19," D ^DIK
  1.  S DA=$O(^DIC(19,"B","AMH P TABLES TOC",0)) I DA S DIK="^DIC(19," D ^DIK
  1.  S DA=$O(^DIC(19,"B","AMH ENTER DNKA",0)) I DA S DIK="^DIC(19," D ^DIK
  1.  Q
  1. POST ;EP
  1.  S DIK="^AMHRCDST(",DIK(1)=".02^AC" D ENALL^DIK
  1.  S DIK="^AMHPROB(",DIK(1)=".03^AC" D ENALL^DIK ;reindex problem ac index
  1.  K ^DD(9002012.2,.05,9)
  1. PROB ;add problems, fix problems
  1.  G COM
  1. P1 ;
  1.  I $D(^AMHPROB("B","302.85")) W !,"Code 302.85 already exists." G P2
  1.  S DIC="^AMHPROB(",X="302.85",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///GENDER IDENTITY DISORDER OF ADOLESCENT OR ADULT;.03///20;.05///302.85;.06///I" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"302.85 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P2 ;
  1.  I $D(^AMHPROB("B","50")) W !,"Code 50 already exists." G P3
  1.  S DIC="^AMHPROB(",X="50",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///TRAUMATIC BEREAVEMENT;.03///50;.05///V62.82;.08///1" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"50 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P3 ;
  1.  I $D(^AMHPROB("B","49.9")) W !,"Code 49.9 already exists." G P4
  1.  S DIC="^AMHPROB(",X="49.9",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///EXPLOITATION;.03///49.9;.05///V61.29" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"49.9 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P4 ;
  1.  I $D(^AMHPROB("B","47.1")) W !,"Code 47.1 already exists." G P5
  1.  S DIC="^AMHPROB(",X="47.1",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///CHILD NEGLECT (SUSPECTED), PHYSICAL;.03///47.1;.05///995.59;.08///1" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"47.1 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P5 ;
  1.  I $D(^AMHPROB("B","47.2")) W !,"Code 47.2 already exists." G P6
  1.  S DIC="^AMHPROB(",X="47.2",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///CHILD NEGLECT (SUSPECTED), MENTAL;.03///47.2;.05///995.51;.08///1" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"47.2 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P6 ;
  1.  I $D(^AMHPROB("B","48.1")) W !,"Code 48.1 already exists." G P7
  1.  S DIC="^AMHPROB(",X="48.1",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///ADULT NEGLECT (SUSPECTED), PHYSICAL;.03///48.1;.05///995.81;.08///1" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"48.1 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P7 ;
  1.  I $D(^AMHPROB("B","48.2")) W !,"Code 48.2 already exists." G P8
  1.  S DIC="^AMHPROB(",X="48.2",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///ADULT NEGLECT (SUSPECTED), MENTAL;.03///48.2;.05///995.82;.08///1" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"48.2 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P8 ;
  1.  I $D(^AMHPROB("B","49.1")) W !,"Code 49.1 already exists." G P9
  1.  S DIC="^AMHPROB(",X="49.1",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///PARTNER NEGLECT (SUSPECTED), PHYSICAL;.03///49.1;.05///995.81;.08///1" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"49.1 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P9 ;
  1.  I $D(^AMHPROB("B","49.2")) W !,"Code 49.2 already exists." G P10
  1.  S DIC="^AMHPROB(",X="49.2",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///PARTNER NEGLECT (SUSPECTED), MENTAL;.03///49.2;.05///995.82;.08///1" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"49.2 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P10 ;
  1.  I $D(^AMHPROB("B","312.39")) W !,"Code 312.39 already exists." G P11
  1.  S DIC="^AMHPROB(",X="312.39",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///IMPULSE CONTROL DIS NED;.03///26;.05///312.39;.06///I" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"312.39 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. P11 ;
  1.  I $D(^AMHPROB("B","8.3")) W !,"Code 8.3 already exists." G FICD
  1.  S DIC="^AMHPROB(",X="8.3",DIC(0)="L",DIADD=1,DLAYGO=9002012.2,DIC("DR")=".02///DID NOT WAIT TO BE SEEN;.03///8.3;.05///V15.81" K DD,DO,D0 D FILE^DICN
  1.  I Y=-1 W !,"312.39 failed"
  1.  D ^XBFMK K DIADD,DLAYGO
  1. FICD ;
  1.  S $P(^AMHPROB(492,0),U,5)=312.81
  1.  S $P(^AMHPROB(476,0),U,5)=312.82
  1.  S $P(^AMHPROB(477,0),U,5)=312.89
  1.  F AMHX=1:1 S AMHY=$T(ICDC+AMHX) Q:$P(AMHY,";;",2)=""  D
  1.  .S D=$P(AMHY,";;",2),I=$P(AMHY,";;",3)
  1.  .S DA=$O(^AMHPROB("B",D,0))
  1.  .I 'DA W !!,"Updating ICD code for ",D," failed." Q
  1.  .S P=$O(^ICD9("AB",I,0)) I 'P W !,"Couldn't find ICD pointer value. ",D," ",I Q
  1.  .S DIE="^AMHPROB(",DR=".05///"_I D ^DIE
  1.  .W AMHY,!
  1.  .I $D(Y) W !,"Updating ICD code for ",D," failed die." Q
  1.  .K DIE,DA,DR
  1.  .Q
  1. COM ;
  1.  NEW AMHX S AMHX=0 F  S AMHX=$O(^AMHPATR(AMHX)) Q:AMHX'=+AMHX  K ^AMHPATR(AMHX,31) W "."
  1.  S DIK="^AMHPATR(" D IXALL^DIK  ;re index desg prov cross references
  1.  ;move comment
  1.  S X=0 F  S X=$O(^AMHREC(X)) Q:X'=+X  D
  1.  .Q:'$D(^AMHREC(X,0))
  1.  .I $P(^AMHREC(X,0),U,17)=0 S $P(^AMHREC(X,0),U,17)=10
  1.  .Q:'$D(^AMHREC(X,12))
  1.  .S Y=^AMHREC(X,12)
  1.  .Q:Y=""
  1.  .Q:$D(^AMHREC(X,81,0))
  1.  .S ^AMHREC(X,81,0)="^^1^1^"_$P($P(^AMHREC(X,0),U),".")_"^"
  1.  .S ^AMHREC(X,81,1,0)=Y
  1.  .K ^AMHREC(X,12)
  1.  .Q
  1. INTAKE ;convert intake documents
  1.  S AMHX=0 F  S AMHX=$O(^AMHPINTK(AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:$D(^AMHPINTK(AMHX,41))  ;already has open field
  1.  .S AMHC=0
  1.  .F AMHF=1100:100:2800 I $D(^DD(9002011.07,AMHF)),$O(^AMHPINTK(AMHX,$E(AMHF,1,2),0)) S AMHFN=$P(^DD(9002011.07,AMHF,0),U) D
  1.  ..S AMHC=AMHC+1,^AMHPINTK(AMHX,41,AMHC,0)=AMHFN,AMHC=AMHC+1,^AMHPINTK(AMHX,41,AMHC,0)=""
  1.  ..S AMHV=0 F  S AMHV=$O(^AMHPINTK(AMHX,$E(AMHF,1,2),AMHV)) Q:AMHV'=+AMHV  D
  1.  ...S AMHC=AMHC+1,^AMHPINTK(AMHX,41,AMHC,0)=^AMHPINTK(AMHX,$E(AMHF,1,2),AMHV,0)
  1.  ...Q
  1.  ..S AMHC=AMHC+1,^AMHPINTK(AMHX,41,AMHC,0)=""
  1.  ..Q
  1.  .S ^AMHPINTK(AMHX,41,0)="^^"_AMHC_"^"_AMHC_"^"_DT_"^^"
  1.  .Q
  1. TP ;
  1.  S AMHTP=0 F  S AMHTP=$O(^AMHPTXP(AMHTP)) Q:AMHTP'=+AMHTP  D
  1.  .S AMHNEW=0
  1.  .I $O(^AMHPTXP(AMHTP,18,0)) S $P(^AMHPTXP(AMHTP,0),U,18)=1,$P(^AMHPTXP(AMHTP,0),U,19)=1
  1.  .Q:$P(^AMHPTXP(AMHTP,0),U,18)
  1.  .W ":",AMHTP
  1.  .;move axis I to wp
  1.  .S X=$G(^AMHPTXP(AMHTP,12))
  1.  .I X]"" S ^AMHPTXP(AMHTP,6,1,0)=X,^AMHPTXP(AMHTP,6,0)="^^1^1^"_DT
  1.  .S X=$G(^AMHPTXP(AMHTP,14))
  1.  .I X]"" S ^AMHPTXP(AMHTP,7,1,0)=X,^AMHPTXP(AMHTP,7,0)="^^1^1^"_DT
  1.  .S $P(^AMHPTXP(AMHTP,0),U,18)=1
  1.  .;move axis ii to wp
  1.  .S X=$G(^AMHPTXP(AMHTP,13))
  1.  .I X]"" S ^AMHPTXP(AMHTP,8,1,0)=X,^AMHPTXP(AMHTP,8,0)="^^1^1^"_DT
  1.  .;move nodes 3,4,5 to node 18
  1.  .S C=0 I $O(^AMHPTXP(AMHTP,3,0)) D
  1.  ..;S C=C+1,^AMHPTXP(AMHTP,18,C,0)="PROBLEM DESCRIPTION"
  1.  ..S X=0 F  S X=$O(^AMHPTXP(AMHTP,3,X)) Q:X'=+X  D
  1.  ...S C=C+1,^AMHPTXP(AMHTP,18,C,0)=^AMHPTXP(AMHTP,3,X,0)
  1.  .I $O(^AMHPTXP(AMHTP,4,0)) D
  1.  ..S C=C+2,^AMHPTXP(AMHTP,18,C,0)="GOALS"
  1.  ..S X=0 F  S X=$O(^AMHPTXP(AMHTP,4,X)) Q:X'=+X  D
  1.  ...S C=C+1,^AMHPTXP(AMHTP,18,C,0)=^AMHPTXP(AMHTP,4,X,0)
  1.  .I $O(^AMHPTXP(AMHTP,5,0)) D
  1.  ..S C=C+2,^AMHPTXP(AMHTP,18,C,0)="OBJECTIVES"
  1.  ..S X=0 F  S X=$O(^AMHPTXP(AMHTP,3,X)) Q:X'=+X  D
  1.  ...S C=C+1,^AMHPTXP(AMHTP,18,C,0)=^AMHPTXP(AMHTP,3,X,0)
  1.  .K ^TMP($J,"AMHPOST1")
  1.  .D GUIR^XBLM("METHOD^AMHPOST1","^TMP($J,""AMHPOST1"",")
  1.  .S X=0 F  S X=$O(^TMP($J,"AMHPOST1",X)) Q:X'=+X  D
  1.  ..S C=C+1
  1.  ..S ^AMHPTXP(AMHTP,18,C,0)=^TMP($J,"AMHPOST1",X)
  1.  .S ^AMHPTXP(AMHTP,18,0)="^^"_C_"^"_C_"^"_DT_"^^"
  1.  .Q
  1. TP2 ;convert again
  1.  S AMHC=0
  1.  S AMHXX=0 F  S AMHXX=$O(^AMHPTXP(AMHXX)) Q:AMHXX'=+AMHXX  D
  1.  .Q:$P(^AMHPTXP(AMHXX,0),U,19)  ;converted 2nd time
  1.  .Q:$O(^AMHPTXP(AMHXX,18,1))
  1.  .K ^TMP($J,"AMHPOST1")
  1.  .D GUIR^XBLM("GATHER^AMHPOST1","^TMP($J,""AMHPOST1"",")
  1.  .S X=0,C=0 F  S X=$O(^TMP($J,"AMHPOST1",X)) Q:X'=+X  D
  1.  ..S C=C+1
  1.  ..S ^AMHPTXP(AMHXX,18,C,0)=^TMP($J,"AMHPOST1",X)
  1.  .S ^AMHPTXP(AMHXX,18,0)="^^"_C_"^"_C_"^"_DT_"^^"
  1.  .S AMHA=0 F  S AMHA=$O(^AMHPTPP("AD",AMHXX,AMHA)) Q:AMHA'=+AMHA  D
  1.  ..S ^AMHPTXP(AMHXX,11)=$G(^AMHPTXP(AMHXX,11))_$P(^AMHPTPP(AMHA,0),U)_"   "
  1.  ..Q
  1.  .S $P(^AMHPTXP(AMHXX,0),U,19)=1  ;conversion 2
  1. EDU ;fix education
  1.  S AMHXX=0 F  S AMHXX=$O(^AMHREDU(AMHXX)) Q:AMHXX'=+AMHXX  D
  1.  .S AMHV=$P(^AMHREDU(AMHXX,0),U,3)
  1.  .Q:'AMHV
  1.  .Q:$P(^AMHREDU(AMHXX,0),U,2)
  1.  .Q:'$D(^AMHREC(AMHV,0))
  1.  .S AMHP=$P(^AMHREC(AMHV,0),U,8)
  1.  .Q:'AMHP
  1.  .S DITC="",DIE="^AMHREDU(",DA=AMHXX,DR=".02////"_AMHP D ^DIE D ^XBFMK K DITC
  1. FIXPROC ;
  1.  S AMHXX=0 F  S AMHXX=$O(^AMHRPROC(AMHXX)) Q:AMHXX'=+AMHXX  D
  1.  .S AMHV=$P(^AMHRPROC(AMHXX,0),U,3)
  1.  .Q:'AMHV
  1.  .Q:$P(^AMHRPROC(AMHXX,0),U,2)
  1.  .Q:'$D(^AMHREC(AMHV,0))
  1.  .S AMHP=$P(^AMHREC(AMHV,0),U,8)
  1.  .Q:'AMHP
  1.  .S DITC="",DIE="^AMHRPROC(",DA=AMHXX,DR=".02////"_AMHP D ^DIE D ^XBFMK K DITC
  1.  Q
  1. ICDC ;;
  1.  ;;2;;V62.4
  1.  ;;294.1;;294.10
  1.  ;;42;;V71.81
  1.  ;;43;;V71.81
  1.  ;;44;;V71.81
  1.  ;;45;;V71.89
  1.  ;;47;;V71.81
  1.  ;;48;;V71.81
  1.  ;;49;;V71.81
  1.  ;;62;;V61.8
  1.  ;;65;;V25.09
  1.  ;;84;;V62.1
  1.  ;;90;;V62.3
  1.  ;;98;;V62.0
  1.  ;;99;;V68.89
  1.  ;;42.1;;V71.81
  1.  ;;42.2;;V71.81
  1.  ;;42.3;;V71.81
  1.  ;;43.1;;V71.81
  1.  ;;43.2;;V71.81
  1.  ;;43.3;;V71.81
  1.  ;;44.1;;V71.81
  1.  ;;44.2;;V71.81
  1.  ;;44.3;;V71.81
  1.  ;;45.1;;V71.89
  1.  ;;45.2;;V71.89
  1.  ;;45.3;;V71.89
  1.  ;;14;;296.20
  1.  ;;16;;297.9
  1.  ;;25;;312.89
  1.  ;;46.1;;V62.83
  1.  ;;995.5;;995.50
  1.  ;;995.81;;995.80
  1.  ;;46.2;;V15.41
  1.  ;;294.8;;294.0
  1.  ;;21.1;;292.9
  1.  ;;290.3;;331.0
  1.  ;;291.5;;291.89
  1.  ;;312.82;;312.82
  1.  ;;312.89;;312.9
  1.  ;;314.9;;314.01
  1.  ;;333.92;;333.92
  1.  ;;54.1;;798.2
  1.  ;;54.2;;V66.7
  1.  ;;46.3;;V71.81
  1.  ;;47.1;;V71.81
  1.  ;;47.2;;V71.81
  1.  ;;48.1;;V71.81
  1.  ;;48.2;;V71.81
  1.  ;;49.1;;V71.81
  1.  ;;49.2;;V71.81
  1.  ;;
  1.  ;
  1.  ;;
  1.  ;