SD53FY12 ;ALB/RLC- Stop Code/DSS Identifier Update 6/18/07
;;5.3;Scheduling;**583**;AUG 13, 1993;Build 3
;
;** This patch is used as a Post-Init in a KIDS build to modify the
;** the CLINIC STOP file [^DIC(40.7,] for FY2012 updates.
;
Q
;
EN ;** Add/inactivate/change/reactivate DSS IDs (stop codes)
;** The following code executes if file modifications exist
;
N SDVAR,SDAUMF,TYPE
S SDAUMF=1
D UPDATEDD("O") ;unlock file to allow edits
D:$P($T(NEW+1),";;",2)'="QUIT" ADD
D:$P($T(OLD+1),";;",2)'="QUIT" INACT
D:$P($T(ACT+1),";;",2)'="QUIT" REACT
D:$P($T(CHNG+1),";;",2)'="QUIT" CHANGE
D:$P($T(CDR+1),";;",2)'="QUIT" CDRNUM
D:$P($T(REST+1),";;",2)'="QUIT" RESTR
D UPDATEDD("C") ;lock file back down
Q
;
;
ADD ;** Add DSS IDs
;
; SDXX is in format:
; STOP CODE NAME^AMIS #^RESTRICTION TYPE^REST. DATE^CDR #
;
N SDX,SDXX
S SDVAR=1
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Adding new Clinic Stops (DSS IDs) to CLINIC STOP File (#40.7)...")
;
;** NOTE: The following line is for DSS IDs that are not yet active
D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 10/1/2011]")
S DIC(0)="L",DLAYGO=40.7,DIC="^DIC(40.7,"
F SDX=1:1 K DD,DO,DA S SDXX=$P($T(NEW+SDX),";;",2) Q:SDXX="QUIT" DO
.S DIC("DR")="1////"_$P(SDXX,"^",2)_$S('+$P(SDXX,U,5):"",1:";4////"_$P(SDXX,"^",5))
.S DIC("DR")=DIC("DR")_";5////"_$P(SDXX,"^",3)_";6///"_$P(SDXX,"^",4)
.S X=$P(SDXX,"^",1)
.I '$D(^DIC(40.7,"C",$P(SDXX,"^",2))) D FILE^DICN,MESS Q
.I $D(^DIC(40.7,"C",$P(SDXX,"^",2))) D EDIT(SDXX),MESSEX
K DIC,DLAYGO,X
Q
;
EDIT(SDXX) ;- Edit fields w/new values if stop code record already exists
;
Q:$G(SDXX)=""
N DA,DIE,DLAYGO,DR
S DA=+$O(^DIC(40.7,"C",+$P(SDXX,"^",2),0))
Q:'DA
S DIE="^DIC(40.7,",DR=".01////"_$P(SDXX,"^")_";1////"_$P(SDXX,"^",2)_";2////@"_$S('+$P(SDXX,U,5):"",1:";4////"_$P(SDXX,"^",5))_";5////"_$P(SDXX,"^",3)_";6///"_$P(SDXX,"^",4)
D ^DIE
Q
INACT ;** Inactivate DSS IDs
;
; SDXX is in format:
; AMIS #^^INACTIVATION DATE (in FileMan format)
;
N SDX,SDDA,SDXX,SDINDT,SDEXDT
S SDVAR=1
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Inactivating Clinic Stops (DSS IDs) in CLINIC STOP File (#40.7)...")
D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used AFTER the indicated inactivation date]")
F SDX=1:1 K DD,DO,DA S SDXX=$P($T(OLD+SDX),";;",2) Q:SDXX="QUIT" DO
. I +$P(SDXX,"^",3) D
.. S X=$P(SDXX,"^",3)
.. ;
.. ;- Validate date passed in
.. S %DT="FTX"
.. D ^%DT
.. Q:Y<0
.. S SDINDT=Y
.. D DD^%DT
.. S SDEXDT=Y
.. S SDDA=0
.. F S SDDA=$O(^DIC(40.7,"C",+SDXX,SDDA)) Q:'SDDA D
... I $D(^DIC(40.7,SDDA,0)) I $P(^(0),U,3)="" D
.... S DA=SDDA,DR="2////^S X=SDINDT",DIE="^DIC(40.7,"
.... D ^DIE,MESI(SDEXDT)
K %,%H,%I,DR,DA,DIC,DIE,DLAYGO,X,%DT,Y
Q
;
CHANGE ;** Change DSS ID names
;
; SDXX is in format:
; STOP CODE NAME^AMIS #^^NEW STOP CODE NAME
;
N SDX,SDXX,SDDA
S SDVAR=1
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Changing Clinic Stop (DSS ID) names in CLINIC STOP File (#40.7)...")
F SDX=1:1 K DD,DO,DA S SDXX=$P($T(CHNG+SDX),";;",2) Q:SDXX="QUIT" DO
.S SDDA=0
.F S SDDA=$O(^DIC(40.7,"C",$P(SDXX,U,2),SDDA)) Q:'SDDA D
..I $D(^DIC(40.7,SDDA,0)) I $P(^(0),U,3)="" D
...S DA=SDDA,DR=".01///"_$P(SDXX,U,4),DIE="^DIC(40.7,"
...D ^DIE,MESC
K DIE,DR,DA
Q
;
CDRNUM ;** Change CDR numbers
;
; SDXX is in format:
; STOP CODE NAME (AMIS #) ^ AMIS # ^ OLD CDR # ^ NEW CDR #
;
N SDX,SDXX,SDDA
S SDVAR=2
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Changing CDR numbers in CLINIC STOP File (#40.7)...")
F SDX=1:1 K DD,DO,DA S SDXX=$P($T(CDR+SDX),";;",2) Q:SDXX="QUIT" DO
.S SDDA=+$O(^DIC(40.7,"C",$P(SDXX,U,2),0))
.I $D(^DIC(40.7,SDDA,0)) DO
..S DA=SDDA,DR="4///"_$P(SDXX,U,4),DIE="^DIC(40.7,"
..D ^DIE,MESN
K DIE,DR,DA,X
Q
;
REACT ;** Reactivate DSS IDs
;
; SDXX is in format:
; AMIS #^
;
N SDX,SDDA,SDXX
S SDVAR=1
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Reactivating Clinic Stops (DSS IDs) in CLINIC STOP File (#40.7)...")
;Inactivation date is an uneditable field, cannot use DIE to delete so
;must manually set piece to null if stop code being reactivated.
F SDX=1:1 K DD,DO,DA S SDXX=$P($T(ACT+SDX),";;",2) Q:SDXX="QUIT" D
.S SDDA=+$O(^DIC(40.7,"C",+SDXX,0))
.I $P($G(^DIC(40.7,SDDA,0)),"^",3)'="" S $P(^DIC(40.7,SDDA,0),U,3)="" D MESA
Q
;
RESTR ;** Change Restriction Data
;
; SDXX is in format:
; STOP CODE NAME^STOP CODE NUMBER^RESTRICTION TYPE^RESTRICTION DATE
;
N SDX,SDXX,SDDA
S SDVAR=3
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Changing Restriction Data in CLINIC STOP File (#40.7)...")
F SDX=1:1 K DD,DO,DA S SDXX=$P($T(REST+SDX),";;",2) Q:SDXX="QUIT" D
.S SDDA=0
.F S SDDA=$O(^DIC(40.7,"C",$P(SDXX,U,2),SDDA)) Q:'SDDA D
..I $D(^DIC(40.7,SDDA,0)) I $P(^(0),U,3)="" D
...S DA=SDDA,DR="5////"_$P(SDXX,U,3)_";6///@",DIE="^DIC(40.7,"
...D ^DIE,MESR
K DIE,DR,DA,X
Q
;
MESS ;** Add message
N ECXADMSG
I +$G(SDVAR) D HDR(SDVAR)
D MES^XPDUTL(" ")
S ECXADMSG="Added: "_$P(SDXX,"^",2)_" "_$P(SDXX,"^")
I $P(SDXX,"^",5)'="" S ECXADMSG=ECXADMSG_" [CDR#: "_$P(SDXX,"^",5)_"]"
D MES^XPDUTL(ECXADMSG)
I $P(SDXX,"^",3)'="" S ECXADMSG=" Restricted Type: "_$P(SDXX,"^",3)_" Restricted Date: "_$P(SDXX,"^",4)
D MES^XPDUTL(ECXADMSG)
K SDVAR
Q
;
MESSEX ;** Display message if stop code already exists
N ECXADMSG
I +$G(SDVAR) D HDR(SDVAR)
D MES^XPDUTL(" ")
S ECXADMSG=" "_$P(SDXX,"^",2)_" "_$P(SDXX,"^")_" already exists."
D MES^XPDUTL(ECXADMSG)
K SDVAR
Q
;
MESI(SDEXDT) ;** Inactivate message
;
; Parameter:
; SDEXDT - Date inactivation affective (External Format)
;
N SDINMSG
I +$G(SDVAR) D HDR(SDVAR)
I $G(SDEXDT)="" S SDEXDT="UNKNOWN"
D MES^XPDUTL(" ")
S SDINMSG="Inactivated: "_+SDXX_" "_$P($G(^DIC(40.7,SDDA,0)),"^")_" as of "_SDEXDT
D MES^XPDUTL(SDINMSG)
K SDVAR
Q
;
MESA ;** Reactivate message
;
N SDACMSG
I +$G(SDVAR) D HDR(SDVAR)
D MES^XPDUTL(" ")
S SDACMSG="Reactivated: "_+SDXX_" "_$P($G(^DIC(40.7,SDDA,0)),"^")
D MES^XPDUTL(SDACMSG)
K SDVAR
Q
;
MESC ;** Change message
N SDCMSG,SDCMSG1
I +$G(SDVAR) D HDR(SDVAR)
D MES^XPDUTL(" ")
S SDCMSG="Changed: "_$P(SDXX,U,2)_" "_$P(SDXX,U)
S SDCMSG1=" to: "_$P(SDXX,U,2)_" "_$P(SDXX,U,4)
D MES^XPDUTL(SDCMSG)
D MES^XPDUTL(SDCMSG1)
K SDVAR
Q
;
MESN ;** Change number
N SDNMSG,SDNMSG1
I +$G(SDVAR) D HDR(SDVAR)
D MES^XPDUTL(" ")
S SDNMSG=" Changed: "_$P(SDXX,U,2)_" "_$P(SDXX,U)
S SDNMSG1=" : "_$P(SDXX,U,3)_" Date: "_$P(SDXX,U,5)
D MES^XPDUTL(SDNMSG)
D MES^XPDUTL(SDNMSG1)
K SDVAR
Q
MESR ;** Restricting Stop Code
N SDNMSG,SDNMSG1
I +$G(SDVAR) D HDR(SDVAR)
D MES^XPDUTL(" ")
S SDNMSG="Changed: "_$P(SDXX,U,2)_" "_$P(SDXX,U)_" "_$P(SDXX,U,5)_" "_$P(SDXX,U,6)
S SDNMSG1=" to: "_$P(SDXX,U,3)_" "_$P(SDXX,U,4)
D MES^XPDUTL(SDNMSG)
D MES^XPDUTL(SDNMSG1)
K SDVAR
Q
;
HDR(SDVAR) ;- Header
Q:'$G(SDVAR)
N SDHDR
S SDHDR=$P($T(@("HDR"_SDVAR)),";;",2)
D BMES^XPDUTL(SDHDR)
Q
;
;
HDR1 ;; Stop Code Name
;
HDR2 ;; CDR Stop Code Name
;
HDR3 ;; Stop Code Name Rest. Type Date
;
UPDATEDD(TYPE) ;update DD for 40.7 to either unlock file to allow edits or lock
;file down to prohibit edits
;TYPE="O" to unlock file and TYPE="C" to lock file
N I
I TYPE="C" D ;restrict file edits "lockdown" file
.S ^DD(40.7,.01,7.5)="I $G(DIC(0))[""L"",'$D(SDAUMF) D EN^DDIOL(""Entries can only be added by the Stop Code Council."","""",""!?5"") K X"
.F I=1:1:6 I $P(^DD(40.7,I,0),U,2)'["I" S $P(^DD(40.7,I,0),U,2)=$P(^DD(40.7,I,0),U,2)_"I" ;makes all fields uneditable
I TYPE="O" D ;remove restrictions "unlock" file
.K ^DD(40.7,.01,7.5)
.F I=1:1:6 S $P(^DD(40.7,I,0),U,2)=$TR($P(^DD(40.7,I,0),U,2),"I","")
Q
;
NEW ;DSS IDs to add- ex ;;STOP CODE NAME^NUMBER^RESTRICTION TYPE^RESTRICTION DATE^CDR
;;PM&R ASSIST TECH CLINIC^240^E
;;TELEPHONE PRIMARY CARE^338^P^10/1/2011
;;SF TELECARE FROM NONVAMC PROV^698^S^10/1/2011
;;QUIT
;
OLD ;DSS IDs to be inactivated- ex. ;;AMIS NUMBER^^INACTIVE DATE
;;480^COMPREHENSIVE FUNDOSCOPY EXAM^10/1/2011
;;QUIT
;
CHNG ;DSS ID name changes- example ;;STOP CODE NAME^NUMBER^^NEW NAME
;;CARDIOVASCULAR NUCLEAR MED^110^^INTERV RAD PRE/POST CNSLT
;;MOVE PROGRAM IND^372^^MOVE! PGM INDIV
;;MOVE PROGRAM GRP^373^^MOVE! PGM GROUP
;;IPCC MEDICAL CENTER VISIT^504^^GRANT & PER DIEM GROUP
;;DRUG DEPENDENCE-INDIVIDUAL^507^^HUD/VASH GROUP
;;ALCOHOL TREATMENT-INDIVIDUAL^508^^HCHV/HCMI GROUP
;;GRANT AND PER DIEM^511^^GRANT & PER DIEM INDIV
;;HUD/VASH^522^^HUD/VASH INDIV
;;HCHV/HCMI^529^^HCHV/HCMI INDIV
;;NC RTCV TELECARE NONVAMC^648^^RT CVT W NONVAMC PROVID LOC
;;VA-REFER HOME/COMMUN CARE PROV^682^^VA-REFER TO HCBC PROV
;;CCHT NON-VIDEO MONITORING^683^^HT NON-VIDEO MONITORING
;;CCHT NON-VIDEO INTRVNTION^684^^HT NON-VIDEO INTERVENTION
;;CARE OF CCHT PROGRAM PATIENTS^685^^HT PROGRAM PATIENTS
;;PHONE CONTACT BY CC STAFF^686^^TELEPHONE BY HT STAFF
;;QUIT
;
CDR ;CDR account change- ex. ;;STOP CODE NAME^NUMBER^CDR # (old)^CDR# (new)
;;QUIT
;
ACT ;DSS IDs to be reactivated- example ;;NUMBER^
;;110^
;;504^
;;507^
;;508^
;;QUIT
;
REST ;Change restriction - ;;STOP CODE NAME^NUMBER^REST TYPE^RES DATE^OLD
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53FY12 9593 printed Nov 22, 2024@17:55:36 Page 2
SD53FY12 ;ALB/RLC- Stop Code/DSS Identifier Update 6/18/07
+1 ;;5.3;Scheduling;**583**;AUG 13, 1993;Build 3
+2 ;
+3 ;** This patch is used as a Post-Init in a KIDS build to modify the
+4 ;** the CLINIC STOP file [^DIC(40.7,] for FY2012 updates.
+5 ;
+6 QUIT
+7 ;
EN ;** Add/inactivate/change/reactivate DSS IDs (stop codes)
+1 ;** The following code executes if file modifications exist
+2 ;
+3 NEW SDVAR,SDAUMF,TYPE
+4 SET SDAUMF=1
+5 ;unlock file to allow edits
DO UPDATEDD("O")
+6 if $PIECE($TEXT(NEW+1),";;",2)'="QUIT"
DO ADD
+7 if $PIECE($TEXT(OLD+1),";;",2)'="QUIT"
DO INACT
+8 if $PIECE($TEXT(ACT+1),";;",2)'="QUIT"
DO REACT
+9 if $PIECE($TEXT(CHNG+1),";;",2)'="QUIT"
DO CHANGE
+10 if $PIECE($TEXT(CDR+1),";;",2)'="QUIT"
DO CDRNUM
+11 if $PIECE($TEXT(REST+1),";;",2)'="QUIT"
DO RESTR
+12 ;lock file back down
DO UPDATEDD("C")
+13 QUIT
+14 ;
+15 ;
ADD ;** Add DSS IDs
+1 ;
+2 ; SDXX is in format:
+3 ; STOP CODE NAME^AMIS #^RESTRICTION TYPE^REST. DATE^CDR #
+4 ;
+5 NEW SDX,SDXX
+6 SET SDVAR=1
+7 DO MES^XPDUTL("")
+8 DO BMES^XPDUTL(">>> Adding new Clinic Stops (DSS IDs) to CLINIC STOP File (#40.7)...")
+9 ;
+10 ;** NOTE: The following line is for DSS IDs that are not yet active
+11 DO BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 10/1/2011]")
+12 SET DIC(0)="L"
SET DLAYGO=40.7
SET DIC="^DIC(40.7,"
+13 FOR SDX=1:1
KILL DD,DO,DA
SET SDXX=$PIECE($TEXT(NEW+SDX),";;",2)
if SDXX="QUIT"
QUIT
Begin DoDot:1
+14 SET DIC("DR")="1////"_$PIECE(SDXX,"^",2)_$SELECT('+$PIECE(SDXX,U,5):"",1:";4////"_$PIECE(SDXX,"^",5))
+15 SET DIC("DR")=DIC("DR")_";5////"_$PIECE(SDXX,"^",3)_";6///"_$PIECE(SDXX,"^",4)
+16 SET X=$PIECE(SDXX,"^",1)
+17 IF '$DATA(^DIC(40.7,"C",$PIECE(SDXX,"^",2)))
DO FILE^DICN
DO MESS
QUIT
+18 IF $DATA(^DIC(40.7,"C",$PIECE(SDXX,"^",2)))
DO EDIT(SDXX)
DO MESSEX
End DoDot:1
+19 KILL DIC,DLAYGO,X
+20 QUIT
+21 ;
EDIT(SDXX) ;- Edit fields w/new values if stop code record already exists
+1 ;
+2 if $GET(SDXX)=""
QUIT
+3 NEW DA,DIE,DLAYGO,DR
+4 SET DA=+$ORDER(^DIC(40.7,"C",+$PIECE(SDXX,"^",2),0))
+5 if 'DA
QUIT
+6 SET DIE="^DIC(40.7,"
SET DR=".01////"_$PIECE(SDXX,"^")_";1////"_$PIECE(SDXX,"^",2)_";2////@"_$SELECT('+$PIECE(SDXX,U,5):"",1:";4////"_$PIECE(SDXX,"^",5))_";5////"_$PIECE(SDXX,"^",3)_";6///"_$PIECE(SDXX,"^",4)
+7 DO ^DIE
+8 QUIT
INACT ;** Inactivate DSS IDs
+1 ;
+2 ; SDXX is in format:
+3 ; AMIS #^^INACTIVATION DATE (in FileMan format)
+4 ;
+5 NEW SDX,SDDA,SDXX,SDINDT,SDEXDT
+6 SET SDVAR=1
+7 DO MES^XPDUTL("")
+8 DO BMES^XPDUTL(">>> Inactivating Clinic Stops (DSS IDs) in CLINIC STOP File (#40.7)...")
+9 DO BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used AFTER the indicated inactivation date]")
+10 FOR SDX=1:1
KILL DD,DO,DA
SET SDXX=$PIECE($TEXT(OLD+SDX),";;",2)
if SDXX="QUIT"
QUIT
Begin DoDot:1
+11 IF +$PIECE(SDXX,"^",3)
Begin DoDot:2
+12 SET X=$PIECE(SDXX,"^",3)
+13 ;
+14 ;- Validate date passed in
+15 SET %DT="FTX"
+16 DO ^%DT
+17 if Y<0
QUIT
+18 SET SDINDT=Y
+19 DO DD^%DT
+20 SET SDEXDT=Y
+21 SET SDDA=0
+22 FOR
SET SDDA=$ORDER(^DIC(40.7,"C",+SDXX,SDDA))
if 'SDDA
QUIT
Begin DoDot:3
+23 IF $DATA(^DIC(40.7,SDDA,0))
IF $PIECE(^(0),U,3)=""
Begin DoDot:4
+24 SET DA=SDDA
SET DR="2////^S X=SDINDT"
SET DIE="^DIC(40.7,"
+25 DO ^DIE
DO MESI(SDEXDT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 KILL %,%H,%I,DR,DA,DIC,DIE,DLAYGO,X,%DT,Y
+27 QUIT
+28 ;
CHANGE ;** Change DSS ID names
+1 ;
+2 ; SDXX is in format:
+3 ; STOP CODE NAME^AMIS #^^NEW STOP CODE NAME
+4 ;
+5 NEW SDX,SDXX,SDDA
+6 SET SDVAR=1
+7 DO MES^XPDUTL("")
+8 DO BMES^XPDUTL(">>> Changing Clinic Stop (DSS ID) names in CLINIC STOP File (#40.7)...")
+9 FOR SDX=1:1
KILL DD,DO,DA
SET SDXX=$PIECE($TEXT(CHNG+SDX),";;",2)
if SDXX="QUIT"
QUIT
Begin DoDot:1
+10 SET SDDA=0
+11 FOR
SET SDDA=$ORDER(^DIC(40.7,"C",$PIECE(SDXX,U,2),SDDA))
if 'SDDA
QUIT
Begin DoDot:2
+12 IF $DATA(^DIC(40.7,SDDA,0))
IF $PIECE(^(0),U,3)=""
Begin DoDot:3
+13 SET DA=SDDA
SET DR=".01///"_$PIECE(SDXX,U,4)
SET DIE="^DIC(40.7,"
+14 DO ^DIE
DO MESC
End DoDot:3
End DoDot:2
End DoDot:1
+15 KILL DIE,DR,DA
+16 QUIT
+17 ;
CDRNUM ;** Change CDR numbers
+1 ;
+2 ; SDXX is in format:
+3 ; STOP CODE NAME (AMIS #) ^ AMIS # ^ OLD CDR # ^ NEW CDR #
+4 ;
+5 NEW SDX,SDXX,SDDA
+6 SET SDVAR=2
+7 DO MES^XPDUTL("")
+8 DO BMES^XPDUTL(">>> Changing CDR numbers in CLINIC STOP File (#40.7)...")
+9 FOR SDX=1:1
KILL DD,DO,DA
SET SDXX=$PIECE($TEXT(CDR+SDX),";;",2)
if SDXX="QUIT"
QUIT
Begin DoDot:1
+10 SET SDDA=+$ORDER(^DIC(40.7,"C",$PIECE(SDXX,U,2),0))
+11 IF $DATA(^DIC(40.7,SDDA,0))
Begin DoDot:2
+12 SET DA=SDDA
SET DR="4///"_$PIECE(SDXX,U,4)
SET DIE="^DIC(40.7,"
+13 DO ^DIE
DO MESN
End DoDot:2
End DoDot:1
+14 KILL DIE,DR,DA,X
+15 QUIT
+16 ;
REACT ;** Reactivate DSS IDs
+1 ;
+2 ; SDXX is in format:
+3 ; AMIS #^
+4 ;
+5 NEW SDX,SDDA,SDXX
+6 SET SDVAR=1
+7 DO MES^XPDUTL("")
+8 DO BMES^XPDUTL(">>> Reactivating Clinic Stops (DSS IDs) in CLINIC STOP File (#40.7)...")
+9 ;Inactivation date is an uneditable field, cannot use DIE to delete so
+10 ;must manually set piece to null if stop code being reactivated.
+11 FOR SDX=1:1
KILL DD,DO,DA
SET SDXX=$PIECE($TEXT(ACT+SDX),";;",2)
if SDXX="QUIT"
QUIT
Begin DoDot:1
+12 SET SDDA=+$ORDER(^DIC(40.7,"C",+SDXX,0))
+13 IF $PIECE($GET(^DIC(40.7,SDDA,0)),"^",3)'=""
SET $PIECE(^DIC(40.7,SDDA,0),U,3)=""
DO MESA
End DoDot:1
+14 QUIT
+15 ;
RESTR ;** Change Restriction Data
+1 ;
+2 ; SDXX is in format:
+3 ; STOP CODE NAME^STOP CODE NUMBER^RESTRICTION TYPE^RESTRICTION DATE
+4 ;
+5 NEW SDX,SDXX,SDDA
+6 SET SDVAR=3
+7 DO MES^XPDUTL("")
+8 DO BMES^XPDUTL(">>> Changing Restriction Data in CLINIC STOP File (#40.7)...")
+9 FOR SDX=1:1
KILL DD,DO,DA
SET SDXX=$PIECE($TEXT(REST+SDX),";;",2)
if SDXX="QUIT"
QUIT
Begin DoDot:1
+10 SET SDDA=0
+11 FOR
SET SDDA=$ORDER(^DIC(40.7,"C",$PIECE(SDXX,U,2),SDDA))
if 'SDDA
QUIT
Begin DoDot:2
+12 IF $DATA(^DIC(40.7,SDDA,0))
IF $PIECE(^(0),U,3)=""
Begin DoDot:3
+13 SET DA=SDDA
SET DR="5////"_$PIECE(SDXX,U,3)_";6///@"
SET DIE="^DIC(40.7,"
+14 DO ^DIE
DO MESR
End DoDot:3
End DoDot:2
End DoDot:1
+15 KILL DIE,DR,DA,X
+16 QUIT
+17 ;
MESS ;** Add message
+1 NEW ECXADMSG
+2 IF +$GET(SDVAR)
DO HDR(SDVAR)
+3 DO MES^XPDUTL(" ")
+4 SET ECXADMSG="Added: "_$PIECE(SDXX,"^",2)_" "_$PIECE(SDXX,"^")
+5 IF $PIECE(SDXX,"^",5)'=""
SET ECXADMSG=ECXADMSG_" [CDR#: "_$PIECE(SDXX,"^",5)_"]"
+6 DO MES^XPDUTL(ECXADMSG)
+7 IF $PIECE(SDXX,"^",3)'=""
SET ECXADMSG=" Restricted Type: "_$PIECE(SDXX,"^",3)_" Restricted Date: "_$PIECE(SDXX,"^",4)
+8 DO MES^XPDUTL(ECXADMSG)
+9 KILL SDVAR
+10 QUIT
+11 ;
MESSEX ;** Display message if stop code already exists
+1 NEW ECXADMSG
+2 IF +$GET(SDVAR)
DO HDR(SDVAR)
+3 DO MES^XPDUTL(" ")
+4 SET ECXADMSG=" "_$PIECE(SDXX,"^",2)_" "_$PIECE(SDXX,"^")_" already exists."
+5 DO MES^XPDUTL(ECXADMSG)
+6 KILL SDVAR
+7 QUIT
+8 ;
MESI(SDEXDT) ;** Inactivate message
+1 ;
+2 ; Parameter:
+3 ; SDEXDT - Date inactivation affective (External Format)
+4 ;
+5 NEW SDINMSG
+6 IF +$GET(SDVAR)
DO HDR(SDVAR)
+7 IF $GET(SDEXDT)=""
SET SDEXDT="UNKNOWN"
+8 DO MES^XPDUTL(" ")
+9 SET SDINMSG="Inactivated: "_+SDXX_" "_$PIECE($GET(^DIC(40.7,SDDA,0)),"^")_" as of "_SDEXDT
+10 DO MES^XPDUTL(SDINMSG)
+11 KILL SDVAR
+12 QUIT
+13 ;
MESA ;** Reactivate message
+1 ;
+2 NEW SDACMSG
+3 IF +$GET(SDVAR)
DO HDR(SDVAR)
+4 DO MES^XPDUTL(" ")
+5 SET SDACMSG="Reactivated: "_+SDXX_" "_$PIECE($GET(^DIC(40.7,SDDA,0)),"^")
+6 DO MES^XPDUTL(SDACMSG)
+7 KILL SDVAR
+8 QUIT
+9 ;
MESC ;** Change message
+1 NEW SDCMSG,SDCMSG1
+2 IF +$GET(SDVAR)
DO HDR(SDVAR)
+3 DO MES^XPDUTL(" ")
+4 SET SDCMSG="Changed: "_$PIECE(SDXX,U,2)_" "_$PIECE(SDXX,U)
+5 SET SDCMSG1=" to: "_$PIECE(SDXX,U,2)_" "_$PIECE(SDXX,U,4)
+6 DO MES^XPDUTL(SDCMSG)
+7 DO MES^XPDUTL(SDCMSG1)
+8 KILL SDVAR
+9 QUIT
+10 ;
MESN ;** Change number
+1 NEW SDNMSG,SDNMSG1
+2 IF +$GET(SDVAR)
DO HDR(SDVAR)
+3 DO MES^XPDUTL(" ")
+4 SET SDNMSG=" Changed: "_$PIECE(SDXX,U,2)_" "_$PIECE(SDXX,U)
+5 SET SDNMSG1=" : "_$PIECE(SDXX,U,3)_" Date: "_$PIECE(SDXX,U,5)
+6 DO MES^XPDUTL(SDNMSG)
+7 DO MES^XPDUTL(SDNMSG1)
+8 KILL SDVAR
+9 QUIT
MESR ;** Restricting Stop Code
+1 NEW SDNMSG,SDNMSG1
+2 IF +$GET(SDVAR)
DO HDR(SDVAR)
+3 DO MES^XPDUTL(" ")
+4 SET SDNMSG="Changed: "_$PIECE(SDXX,U,2)_" "_$PIECE(SDXX,U)_" "_$PIECE(SDXX,U,5)_" "_$PIECE(SDXX,U,6)
+5 SET SDNMSG1=" to: "_$PIECE(SDXX,U,3)_" "_$PIECE(SDXX,U,4)
+6 DO MES^XPDUTL(SDNMSG)
+7 DO MES^XPDUTL(SDNMSG1)
+8 KILL SDVAR
+9 QUIT
+10 ;
HDR(SDVAR) ;- Header
+1 if '$GET(SDVAR)
QUIT
+2 NEW SDHDR
+3 SET SDHDR=$PIECE($TEXT(@("HDR"_SDVAR)),";;",2)
+4 DO BMES^XPDUTL(SDHDR)
+5 QUIT
+6 ;
+7 ;
HDR1 ;; Stop Code Name
+1 ;
HDR2 ;; CDR Stop Code Name
+1 ;
HDR3 ;; Stop Code Name Rest. Type Date
+1 ;
UPDATEDD(TYPE) ;update DD for 40.7 to either unlock file to allow edits or lock
+1 ;file down to prohibit edits
+2 ;TYPE="O" to unlock file and TYPE="C" to lock file
+3 NEW I
+4 ;restrict file edits "lockdown" file
IF TYPE="C"
Begin DoDot:1
+5 SET ^DD(40.7,.01,7.5)="I $G(DIC(0))[""L"",'$D(SDAUMF) D EN^DDIOL(""Entries can only be added by the Stop Code Council."","""",""!?5"") K X"
+6 ;makes all fields uneditable
FOR I=1:1:6
IF $PIECE(^DD(40.7,I,0),U,2)'["I"
SET $PIECE(^DD(40.7,I,0),U,2)=$PIECE(^DD(40.7,I,0),U,2)_"I"
End DoDot:1
+7 ;remove restrictions "unlock" file
IF TYPE="O"
Begin DoDot:1
+8 KILL ^DD(40.7,.01,7.5)
+9 FOR I=1:1:6
SET $PIECE(^DD(40.7,I,0),U,2)=$TRANSLATE($PIECE(^DD(40.7,I,0),U,2),"I","")
End DoDot:1
+10 QUIT
+11 ;
NEW ;DSS IDs to add- ex ;;STOP CODE NAME^NUMBER^RESTRICTION TYPE^RESTRICTION DATE^CDR
+1 ;;PM&R ASSIST TECH CLINIC^240^E
+2 ;;TELEPHONE PRIMARY CARE^338^P^10/1/2011
+3 ;;SF TELECARE FROM NONVAMC PROV^698^S^10/1/2011
+4 ;;QUIT
+5 ;
OLD ;DSS IDs to be inactivated- ex. ;;AMIS NUMBER^^INACTIVE DATE
+1 ;;480^COMPREHENSIVE FUNDOSCOPY EXAM^10/1/2011
+2 ;;QUIT
+3 ;
CHNG ;DSS ID name changes- example ;;STOP CODE NAME^NUMBER^^NEW NAME
+1 ;;CARDIOVASCULAR NUCLEAR MED^110^^INTERV RAD PRE/POST CNSLT
+2 ;;MOVE PROGRAM IND^372^^MOVE! PGM INDIV
+3 ;;MOVE PROGRAM GRP^373^^MOVE! PGM GROUP
+4 ;;IPCC MEDICAL CENTER VISIT^504^^GRANT & PER DIEM GROUP
+5 ;;DRUG DEPENDENCE-INDIVIDUAL^507^^HUD/VASH GROUP
+6 ;;ALCOHOL TREATMENT-INDIVIDUAL^508^^HCHV/HCMI GROUP
+7 ;;GRANT AND PER DIEM^511^^GRANT & PER DIEM INDIV
+8 ;;HUD/VASH^522^^HUD/VASH INDIV
+9 ;;HCHV/HCMI^529^^HCHV/HCMI INDIV
+10 ;;NC RTCV TELECARE NONVAMC^648^^RT CVT W NONVAMC PROVID LOC
+11 ;;VA-REFER HOME/COMMUN CARE PROV^682^^VA-REFER TO HCBC PROV
+12 ;;CCHT NON-VIDEO MONITORING^683^^HT NON-VIDEO MONITORING
+13 ;;CCHT NON-VIDEO INTRVNTION^684^^HT NON-VIDEO INTERVENTION
+14 ;;CARE OF CCHT PROGRAM PATIENTS^685^^HT PROGRAM PATIENTS
+15 ;;PHONE CONTACT BY CC STAFF^686^^TELEPHONE BY HT STAFF
+16 ;;QUIT
+17 ;
CDR ;CDR account change- ex. ;;STOP CODE NAME^NUMBER^CDR # (old)^CDR# (new)
+1 ;;QUIT
+2 ;
ACT ;DSS IDs to be reactivated- example ;;NUMBER^
+1 ;;110^
+2 ;;504^
+3 ;;507^
+4 ;;508^
+5 ;;QUIT
+6 ;
REST ;Change restriction - ;;STOP CODE NAME^NUMBER^REST TYPE^RES DATE^OLD
+1 ;;QUIT
