SD08SUPP ;ALB/RLC- Stop Code/DSS Identifier Update 6/18/07
;;5.3;Scheduling;**531**;AUG 13, 1993;Build 1
;
;** This patch is used as a Post-Init in a KIDS build to modify the
;** the CLINIC STOP file [^DIC(40.7,] for a FY08 supplemental update.
;
EN ;** Add/inactivate/change/reactivate DSS IDs (stop codes)
;** The following code executes if file modifications exist
;
N SDVAR
D:$P($T(NEW+1),";;",2)'="QUIT" ADD
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 Stop (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: This Stop Code CANNOT be used UNTIL 02/15/2008]")
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
K DIC,DLAYGO,X
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=+$O(^DIC(40.7,"C",$P(SDXX,U,2),0))
.I $D(^DIC(40.7,SDDA,0)) D
..I $P(SDXX,U,2)=571 S DA=SDDA,DR="5////"_$P(SDXX,U,3)_";6///@",DIE="^DIC(40.7," D ^DIE,MESR Q
..S DA=SDDA,DR="5////"_$P(SDXX,U,3)_";6///"_$P(SDXX,U,4),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
;
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
;
NEW ;DSS IDs to add- ex ;;STOP CODE NAME^NUMBER^RESTRICTION TYPE^RESTRICTION DATE^CDR
;;DIABETIC RETINAL SCREENING^718^P^2/15/2008
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD08SUPP 3124 printed Dec 13, 2024@02:44:26 Page 2
SD08SUPP ;ALB/RLC- Stop Code/DSS Identifier Update 6/18/07
+1 ;;5.3;Scheduling;**531**;AUG 13, 1993;Build 1
+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 a FY08 supplemental update.
+5 ;
EN ;** Add/inactivate/change/reactivate DSS IDs (stop codes)
+1 ;** The following code executes if file modifications exist
+2 ;
+3 NEW SDVAR
+4 if $PIECE($TEXT(NEW+1),";;",2)'="QUIT"
DO ADD
+5 QUIT
+6 ;
+7 ;
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 Stop (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: This Stop Code CANNOT be used UNTIL 02/15/2008]")
+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
End DoDot:1
+18 KILL DIC,DLAYGO,X
+19 QUIT
+20 ;
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=+$ORDER(^DIC(40.7,"C",$PIECE(SDXX,U,2),0))
+11 IF $DATA(^DIC(40.7,SDDA,0))
Begin DoDot:2
+12 IF $PIECE(SDXX,U,2)=571
SET DA=SDDA
SET DR="5////"_$PIECE(SDXX,U,3)_";6///@"
SET DIE="^DIC(40.7,"
DO ^DIE
DO MESR
QUIT
+13 SET DA=SDDA
SET DR="5////"_$PIECE(SDXX,U,3)_";6///"_$PIECE(SDXX,U,4)
SET DIE="^DIC(40.7,"
+14 DO ^DIE
DO MESR
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 ;
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 ;
NEW ;DSS IDs to add- ex ;;STOP CODE NAME^NUMBER^RESTRICTION TYPE^RESTRICTION DATE^CDR
+1 ;;DIABETIC RETINAL SCREENING^718^P^2/15/2008
+2 ;;QUIT
