ECX319PT ;ALB/JAP - Post-Install for ECX*3*19 ;January 28, 1999
;;3.0;DSS EXTRACTS;**19**;Dec 22, 1997
;
ADD729 ;** Add DSS Production Units to file #729
;ECXX is in format: CODE^^LONG DESCRIPTION^SHORT DESCRIPTION
N ECXDA,DIE,DR,ECX,ECXX,DIC,DA,X,Y,A1,A3,A4
S ECXDA=$O(^ECX(729,999),-1)
D MES^XPDUTL(" ")
I (ECXDA<77)!(ECXDA>100) D Q
.D MES^XPDUTL(" ")
.D MES^XPDUTL(" WARNING: There is a problem in file #729.")
.I ECXDA<77 D MES^XPDUTL(" Too few records.")
.I ECXDA>100 D MES^XPDUTL(" Too many records.")
.D MES^XPDUTL(" Nothing added...")
.D MES^XPDUTL(" ")
I ECXDA=100,$P(^ECX(729,100,0),U,1)="5I" D
.D MES^XPDUTL(" ")
.D MES^XPDUTL(" It appears that ECX*3*19 has already been installed.")
.D MES^XPDUTL(" But file #729 will be checked and updated as needed.")
.D MES^XPDUTL(" ")
I ECXDA'=100,ECXDA>77,ECXDA<101 D
.D MES^XPDUTL(" ")
.D MES^XPDUTL(" There appears to be some problem in file #729.")
.D MES^XPDUTL(" The file will be updated and should correct this.")
.D MES^XPDUTL(" ")
D MES^XPDUTL(" ")
D MES^XPDUTL(" ")
D MES^XPDUTL(" Adding entries to DSS PRODUCTION UNIT File (#729)...")
D MES^XPDUTL(" ")
S $P(^DD(729,.01,0),U,5)=""
F ECX=1:1 S ECXX=$P($T(NEW729+ECX),";;",2) Q:ECXX="QUIT" D
.S ECXDA=$P(ECXX,";",1),ECXX=$P(ECXX,";",2)
.I $D(^ECX(729,0)),'$D(^ECX(729,ECXDA,0)) D Q
..S A1=$P(ECXX,U,1),A3=$P(ECXX,U,3),A4=$P(ECXX,U,4)
..S DINUM=ECXDA
..S X=A1,DIC="^ECX(729,",DLAYGO=729,DIC(0)="LX",DIC("DR")="1///^S X=A3;2///^S X=A4"
..K DD,DO D FILE^DICN K DLAYGO
..D MESS1
.I $D(^ECX(729,ECXDA,0)) D Q
..S A1=$P(ECXX,U,1),A3=$P(ECXX,U,3)
..S ^ECX(729,ECXDA,0)=ECXX
..S DIK="^ECX(729,",DA=ECXDA D IX^DIK K DA,DIK
..D MESS2
S $P(^DD(729,.01,0),U,5)="K X"
S $P(^ECX(729,0),U,3,4)="100^100"
Q
;
MESS1 ;** Add message
N ECXADMSG
S ECXADMSG=" "_A1_" - "_A3
D MES^XPDUTL(ECXADMSG)
S ECXADMSG=" added as record #"_ECXDA_"."
D MES^XPDUTL(ECXADMSG)
D MES^XPDUTL(" ")
Q
;
MESS2 ;** Update message
N ECXADMSG
S ECXADMSG=" Record #"_ECXDA_" updated as"
D MES^XPDUTL(ECXADMSG)
S ECXADMSG=" "_A1_" - "_A3_"."
D MES^XPDUTL(ECXADMSG)
D MES^XPDUTL(" ")
Q
;
NEW729 ;production unit entries to add;;CODE^^LONG DESCRIPTION^SHORT DESCRIPTION
;;78;20^^GEM Ward^GEMWARD
;;79;21^^Geropsych Ward^GEROPSYWRD
;;80;22^^Inpatient GRECC Care^GREC INPT
;;81;29^^Hospice Ward^HOSPICEWRD
;;82;4A^^Psychiatry Residential Rehab Treatment Centers - General PRRTP^PRRTPGEN
;;83;4B^^Psychiatry Residential Rehab Treatment Centers - PRRP (PTSD)^PRRPPTSD
;;84;4C^^Psychiatry Residential Rehab Treatment Centers - SARRTP (Substance Abuse)^SARRTPSA
;;85;4D^^Psychiatry Residential Rehab Treatment Centers - CWTTR-HCMI^CWTTRHCMI
;;86;4E^^Psychiatry Residential Rehab Treatment Centers - CWTTR-Substance Abuse^CWTTRSA
;;87;4F^^Psychiatry Residential Rehab Treatment Centers - CWTTR-PTSD^CWTTRPTSD
;;88;4G^^Psychiatry Residential Rehab Treatment Centers - CWTTR General^PRRTCGEN
;;89;51^^Domiciliary (D) Routine^DOM ROUT
;;90;52^^Domiciliary - PTSD/PSU^DOM PTSD
;;91;53^^Domiciliary - SLU^DOM SLU
;;92;54^^Domiciliary - CWT Inpatient^DOMCWTINP
;;93;56^^Domiciliary NHCU^DOM NHCU
;;94;57^^Domiciliary ITTP Intensive Transitional Trmt Prog^DOM ITTP
;;95;58^^Domiciliary Substance Abuse^DOMSUBABSE
;;96;59^^Domiciliary CRTU^DOMCRTU
;;97;5A^^Domiciliary Homeless^DOM HMLESS
;;98;5E^^Domiciliary Health Maintenance^DOMHLTHMNT
;;99;5F^^Domiciliary PSI Residential Rehab (Day) Program (PRRP)^PRRP
;;100;5I^^Domiciliary - Rehab^DOMREHAB
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX319PT 3587 printed Dec 13, 2024@01:49:48 Page 2
ECX319PT ;ALB/JAP - Post-Install for ECX*3*19 ;January 28, 1999
+1 ;;3.0;DSS EXTRACTS;**19**;Dec 22, 1997
+2 ;
ADD729 ;** Add DSS Production Units to file #729
+1 ;ECXX is in format: CODE^^LONG DESCRIPTION^SHORT DESCRIPTION
+2 NEW ECXDA,DIE,DR,ECX,ECXX,DIC,DA,X,Y,A1,A3,A4
+3 SET ECXDA=$ORDER(^ECX(729,999),-1)
+4 DO MES^XPDUTL(" ")
+5 IF (ECXDA<77)!(ECXDA>100)
Begin DoDot:1
+6 DO MES^XPDUTL(" ")
+7 DO MES^XPDUTL(" WARNING: There is a problem in file #729.")
+8 IF ECXDA<77
DO MES^XPDUTL(" Too few records.")
+9 IF ECXDA>100
DO MES^XPDUTL(" Too many records.")
+10 DO MES^XPDUTL(" Nothing added...")
+11 DO MES^XPDUTL(" ")
End DoDot:1
QUIT
+12 IF ECXDA=100
IF $PIECE(^ECX(729,100,0),U,1)="5I"
Begin DoDot:1
+13 DO MES^XPDUTL(" ")
+14 DO MES^XPDUTL(" It appears that ECX*3*19 has already been installed.")
+15 DO MES^XPDUTL(" But file #729 will be checked and updated as needed.")
+16 DO MES^XPDUTL(" ")
End DoDot:1
+17 IF ECXDA'=100
IF ECXDA>77
IF ECXDA<101
Begin DoDot:1
+18 DO MES^XPDUTL(" ")
+19 DO MES^XPDUTL(" There appears to be some problem in file #729.")
+20 DO MES^XPDUTL(" The file will be updated and should correct this.")
+21 DO MES^XPDUTL(" ")
End DoDot:1
+22 DO MES^XPDUTL(" ")
+23 DO MES^XPDUTL(" ")
+24 DO MES^XPDUTL(" Adding entries to DSS PRODUCTION UNIT File (#729)...")
+25 DO MES^XPDUTL(" ")
+26 SET $PIECE(^DD(729,.01,0),U,5)=""
+27 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(NEW729+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+28 SET ECXDA=$PIECE(ECXX,";",1)
SET ECXX=$PIECE(ECXX,";",2)
+29 IF $DATA(^ECX(729,0))
IF '$DATA(^ECX(729,ECXDA,0))
Begin DoDot:2
+30 SET A1=$PIECE(ECXX,U,1)
SET A3=$PIECE(ECXX,U,3)
SET A4=$PIECE(ECXX,U,4)
+31 SET DINUM=ECXDA
+32 SET X=A1
SET DIC="^ECX(729,"
SET DLAYGO=729
SET DIC(0)="LX"
SET DIC("DR")="1///^S X=A3;2///^S X=A4"
+33 KILL DD,DO
DO FILE^DICN
KILL DLAYGO
+34 DO MESS1
End DoDot:2
QUIT
+35 IF $DATA(^ECX(729,ECXDA,0))
Begin DoDot:2
+36 SET A1=$PIECE(ECXX,U,1)
SET A3=$PIECE(ECXX,U,3)
+37 SET ^ECX(729,ECXDA,0)=ECXX
+38 SET DIK="^ECX(729,"
SET DA=ECXDA
DO IX^DIK
KILL DA,DIK
+39 DO MESS2
End DoDot:2
QUIT
End DoDot:1
+40 SET $PIECE(^DD(729,.01,0),U,5)="K X"
+41 SET $PIECE(^ECX(729,0),U,3,4)="100^100"
+42 QUIT
+43 ;
MESS1 ;** Add message
+1 NEW ECXADMSG
+2 SET ECXADMSG=" "_A1_" - "_A3
+3 DO MES^XPDUTL(ECXADMSG)
+4 SET ECXADMSG=" added as record #"_ECXDA_"."
+5 DO MES^XPDUTL(ECXADMSG)
+6 DO MES^XPDUTL(" ")
+7 QUIT
+8 ;
MESS2 ;** Update message
+1 NEW ECXADMSG
+2 SET ECXADMSG=" Record #"_ECXDA_" updated as"
+3 DO MES^XPDUTL(ECXADMSG)
+4 SET ECXADMSG=" "_A1_" - "_A3_"."
+5 DO MES^XPDUTL(ECXADMSG)
+6 DO MES^XPDUTL(" ")
+7 QUIT
+8 ;
NEW729 ;production unit entries to add;;CODE^^LONG DESCRIPTION^SHORT DESCRIPTION
+1 ;;78;20^^GEM Ward^GEMWARD
+2 ;;79;21^^Geropsych Ward^GEROPSYWRD
+3 ;;80;22^^Inpatient GRECC Care^GREC INPT
+4 ;;81;29^^Hospice Ward^HOSPICEWRD
+5 ;;82;4A^^Psychiatry Residential Rehab Treatment Centers - General PRRTP^PRRTPGEN
+6 ;;83;4B^^Psychiatry Residential Rehab Treatment Centers - PRRP (PTSD)^PRRPPTSD
+7 ;;84;4C^^Psychiatry Residential Rehab Treatment Centers - SARRTP (Substance Abuse)^SARRTPSA
+8 ;;85;4D^^Psychiatry Residential Rehab Treatment Centers - CWTTR-HCMI^CWTTRHCMI
+9 ;;86;4E^^Psychiatry Residential Rehab Treatment Centers - CWTTR-Substance Abuse^CWTTRSA
+10 ;;87;4F^^Psychiatry Residential Rehab Treatment Centers - CWTTR-PTSD^CWTTRPTSD
+11 ;;88;4G^^Psychiatry Residential Rehab Treatment Centers - CWTTR General^PRRTCGEN
+12 ;;89;51^^Domiciliary (D) Routine^DOM ROUT
+13 ;;90;52^^Domiciliary - PTSD/PSU^DOM PTSD
+14 ;;91;53^^Domiciliary - SLU^DOM SLU
+15 ;;92;54^^Domiciliary - CWT Inpatient^DOMCWTINP
+16 ;;93;56^^Domiciliary NHCU^DOM NHCU
+17 ;;94;57^^Domiciliary ITTP Intensive Transitional Trmt Prog^DOM ITTP
+18 ;;95;58^^Domiciliary Substance Abuse^DOMSUBABSE
+19 ;;96;59^^Domiciliary CRTU^DOMCRTU
+20 ;;97;5A^^Domiciliary Homeless^DOM HMLESS
+21 ;;98;5E^^Domiciliary Health Maintenance^DOMHLTHMNT
+22 ;;99;5F^^Domiciliary PSI Residential Rehab (Day) Program (PRRP)^PRRP
+23 ;;100;5I^^Domiciliary - Rehab^DOMREHAB
+24 ;;QUIT
