DG53418P ;ALB/GRR(EDS) - Add new Intermediae Medicine - LTC Treating Specialty;1/21/02
;;5.3;Registration;**418**;Aug 13, 1993
;
;
EN ;Add Intermediate Medicine - LTC Treating Specialties to the SPECIALITY file (#42.4)
N DGI,DGERR,DGSPEC,DGIFN,DGQUES
S DGIFN=0
F DGI=1:1 S DGSPEC=$P($T(TRSP+DGI),";;",2) Q:DGSPEC="QUIT" D
.D TSPEC
.S DGQUES=$P(DGSPEC,U,9)
.D FAC
.Q
EN2 N DGI,DGMO
D BMES^XPDUTL(" Selected MAS MOVEMENT TYPES will now be renamed")
F DGI=1:1 S DGMO=$P($T(MVED+DGI),";;",2) Q:DGMO="QUIT" D
.D MOVEMT ;Edit movement type names
Q
TSPEC ;Add treating specialty to SPECIALTY File (#42.4)
D BMES^XPDUTL(">>>"_$P(DGSPEC,U,2)_">>>")
N DA,DGFILE,DGMULT,DIC,DIE,DGDA1,DINUM,DLAYGO,DR,X,Y
S DGERR=0
S DIC="^DIC(42.4,"
S DIC(0)="LX"
S DINUM=$P(DGSPEC,U)
S X=$P(DGSPEC,U,2)
S DLAYGO=42.4
D ^DIC
S (DGIFN,DGDA1)=Y
I +DGIFN=-1 D Q
.D MES^XPDUTL(" Entry not added to SPECIALTY File (#42.4). No further updating will occur.")
.D MES^XPDUTL(" Please contact Customer Service for assistance.")
.Q
I $P(DGIFN,U,3)'=1&(+DGIFN'=$P(DGSPEC,U)) D Q
.D MES^XPDUTL(" Entry exists in SPECIALTY File (#42.4), but with a different PTF Code #.")
.D MES^XPDUTL(" No further updating will occur. Please review entry.")
.S DGERR=1
.Q
D MES^XPDUTL(" Entry "_$S($P(DGIFN,U,3)=1:"added to",1:"exists in")_" SPECIALTY File (#42.4).")
D MES^XPDUTL(" Updating SPECIALTY File fields.")
S DIE=DIC
S DR="1///"_$P(DGSPEC,U,3)_";3///"_$P(DGSPEC,U,4)_";4///"_$P(DGSPEC,U,5)_";5///"_$P(DGSPEC,U,6)_";6///"_$P(DGSPEC,U,7)
S DA=+DGIFN
D ^DIE
S DGFILE=42.4
S DGMULT=10
S DIC="^DIC(42.4,"_+DGIFN_",""E"","
D MULT
Q
FAC ;Add treating specialty to Facility Treating Specialty file (#45.7)
I $G(XPDQUES(DGQUES))'=1 D Q
.D BMES^XPDUTL(" Answered NO to install question. Specialty will not be added to FACILITY")
.D MES^XPDUTL(" TREATING SPECIALTY File (#45.7).")
.Q
I +DGIFN<0 D Q
.D BMES^XPDUTL(" Treating specialty not found in SPECIALTY File (#42.4). Cannot")
.D MES^XPDUTL(" be added to FACILITY TREATING SPECIALTY File (#45.7).")
.Q
I DGERR=1 D Q
.D BMES^XPDUTL(" Answered YES to install question. SPECIALITY File (#42.4) does not")
.D MES^XPDUTL(" contain the expected PTF Code #. Cannot update FACILITY TREATING")
.D MES^XPDUTL(" SPECIALTY File (#45.7).")
.Q
N DA,DGFILE,DGMULT,DIC,DIE,DLAYGO,DR,X,Y
S DIC="^DIC(45.7,"
S DIC(0)="LXZ"
S DLAYGO=45.7
S X=$P(DGSPEC,U,2)
D ^DIC
S DGDA1=Y
I +DGDA1=-1 D BMES^XPDUTL(" Entry not added to FACILITY TREATING SPECIALTY File(#45.7).") Q
I $P(DGDA1,U,3)'=1&($P(Y(0),U,2)'=$P(DGSPEC,U)) D Q
.D BMES^XPDUTL(" Entry exists in FACILITY TREATING SPECIALTY File (#45.7), but with")
.D MES^XPDUTL(" a different PTF Code #. No further updating will occur.")
.D MES^XPDUTL(" Please review entry.")
.Q
D BMES^XPDUTL(" Entry "_$S($P(DGDA1,U,3)=1:"added to",1:"exists in")_" FACILITY TREATING SPECIALTY File (#45.7).")
D MES^XPDUTL(" Updating SPECIALTY field...")
S DIE=DIC
S DA=+DGDA1
S DR="1////"_$P(DGSPEC,U)
D ^DIE
S DGFILE=45.7
S DGMULT=100
S DIC="^DIC(45.7,"_+DGDA1_",""E"","
D MULT
Q
MULT ;Add Effective Date
N DA,DIE,DR
S DA(1)=+DGDA1
S DIC(0)="LX"
S DIC("P")=$P(^DD(DGFILE,DGMULT,0),"^",2)
S X=3020101
D ^DIC
S DA=+Y
I +Y=-1 D MES^XPDUTL(" Effective date not added.") Q
D MES^XPDUTL(" Effective date added.")
S DIE=DIC
S DR=".02///Y"
D ^DIE
Q
MOVEMT ;Edit Mas Movement Type Names
N DGFILE,DGIEN,DGON,DGNN,FDAROOT
S DGFILE=405.2
S DGON=$P(DGMO,"^",1) ;Old Name
S DGNN=$P(DGMO,"^",2) ;New Name
S DGIEN=$$FIND1^DIC(DGFILE,,"QX",DGNN)
I DGIEN>0 Q ;New name already in file
S DGIEN=$$FIND1^DIC(DGFILE,,"QX",DGON) ;Old Name
I DGIEN'>0 D ;Didn't find it in file
.D BMES^XPDUTL(" Mas Movement Type '"_DGON_"' not found!")
.D MES^XPDUTL(" Contact the Help Desk.")
I DGIEN>0 D ;entry found
.S FDAROOT(DGFILE,DGIEN_",",.01)=DGNN
.D FILE^DIE("","FDAROOT")
.D BMES^XPDUTL("'"_DGON_"' renamed '"_DGNN_"'")
Q
TRSP ;PTF code^Speciality^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#
;;95^INTERMEDIATE MEDICINE - LTC^IM - LTC^I^N^INTERMEDIATE CARE^1415^^POS1
;;QUIT
MVED ;Original Movement Name^New Movement Name
;;READMISSION TO NHCU/DOMICILIARY^READMISSION TO IMLTC/NHCU/DOMICILIARY
;;TO NHCU FROM HOSP^TO IMLTC/NHCU FROM HOSP
;;TO NHCU FROM DOM^TO IMLTC/NHCU FROM DOM
;;VA NHCU TO CNH^VA IMLTC/NHCU TO CNH
;;DISCHARGE FROM NHCU/DOM WHILE ASIH^DISCHARGE FROM IMLTC/NHCU/DOM WHILE ASIH
;;QUIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53418P 4654 printed Apr 09, 2024@21:55:07 Page 2
DG53418P ;ALB/GRR(EDS) - Add new Intermediae Medicine - LTC Treating Specialty;1/21/02
+1 ;;5.3;Registration;**418**;Aug 13, 1993
+2 ;
+3 ;
EN ;Add Intermediate Medicine - LTC Treating Specialties to the SPECIALITY file (#42.4)
+1 NEW DGI,DGERR,DGSPEC,DGIFN,DGQUES
+2 SET DGIFN=0
+3 FOR DGI=1:1
SET DGSPEC=$PIECE($TEXT(TRSP+DGI),";;",2)
if DGSPEC="QUIT"
QUIT
Begin DoDot:1
+4 DO TSPEC
+5 SET DGQUES=$PIECE(DGSPEC,U,9)
+6 DO FAC
+7 QUIT
End DoDot:1
EN2 NEW DGI,DGMO
+1 DO BMES^XPDUTL(" Selected MAS MOVEMENT TYPES will now be renamed")
+2 FOR DGI=1:1
SET DGMO=$PIECE($TEXT(MVED+DGI),";;",2)
if DGMO="QUIT"
QUIT
Begin DoDot:1
+3 ;Edit movement type names
DO MOVEMT
End DoDot:1
+4 QUIT
TSPEC ;Add treating specialty to SPECIALTY File (#42.4)
+1 DO BMES^XPDUTL(">>>"_$PIECE(DGSPEC,U,2)_">>>")
+2 NEW DA,DGFILE,DGMULT,DIC,DIE,DGDA1,DINUM,DLAYGO,DR,X,Y
+3 SET DGERR=0
+4 SET DIC="^DIC(42.4,"
+5 SET DIC(0)="LX"
+6 SET DINUM=$PIECE(DGSPEC,U)
+7 SET X=$PIECE(DGSPEC,U,2)
+8 SET DLAYGO=42.4
+9 DO ^DIC
+10 SET (DGIFN,DGDA1)=Y
+11 IF +DGIFN=-1
Begin DoDot:1
+12 DO MES^XPDUTL(" Entry not added to SPECIALTY File (#42.4). No further updating will occur.")
+13 DO MES^XPDUTL(" Please contact Customer Service for assistance.")
+14 QUIT
End DoDot:1
QUIT
+15 IF $PIECE(DGIFN,U,3)'=1&(+DGIFN'=$PIECE(DGSPEC,U))
Begin DoDot:1
+16 DO MES^XPDUTL(" Entry exists in SPECIALTY File (#42.4), but with a different PTF Code #.")
+17 DO MES^XPDUTL(" No further updating will occur. Please review entry.")
+18 SET DGERR=1
+19 QUIT
End DoDot:1
QUIT
+20 DO MES^XPDUTL(" Entry "_$SELECT($PIECE(DGIFN,U,3)=1:"added to",1:"exists in")_" SPECIALTY File (#42.4).")
+21 DO MES^XPDUTL(" Updating SPECIALTY File fields.")
+22 SET DIE=DIC
+23 SET DR="1///"_$PIECE(DGSPEC,U,3)_";3///"_$PIECE(DGSPEC,U,4)_";4///"_$PIECE(DGSPEC,U,5)_";5///"_$PIECE(DGSPEC,U,6)_";6///"_$PIECE(DGSPEC,U,7)
+24 SET DA=+DGIFN
+25 DO ^DIE
+26 SET DGFILE=42.4
+27 SET DGMULT=10
+28 SET DIC="^DIC(42.4,"_+DGIFN_",""E"","
+29 DO MULT
+30 QUIT
FAC ;Add treating specialty to Facility Treating Specialty file (#45.7)
+1 IF $GET(XPDQUES(DGQUES))'=1
Begin DoDot:1
+2 DO BMES^XPDUTL(" Answered NO to install question. Specialty will not be added to FACILITY")
+3 DO MES^XPDUTL(" TREATING SPECIALTY File (#45.7).")
+4 QUIT
End DoDot:1
QUIT
+5 IF +DGIFN<0
Begin DoDot:1
+6 DO BMES^XPDUTL(" Treating specialty not found in SPECIALTY File (#42.4). Cannot")
+7 DO MES^XPDUTL(" be added to FACILITY TREATING SPECIALTY File (#45.7).")
+8 QUIT
End DoDot:1
QUIT
+9 IF DGERR=1
Begin DoDot:1
+10 DO BMES^XPDUTL(" Answered YES to install question. SPECIALITY File (#42.4) does not")
+11 DO MES^XPDUTL(" contain the expected PTF Code #. Cannot update FACILITY TREATING")
+12 DO MES^XPDUTL(" SPECIALTY File (#45.7).")
+13 QUIT
End DoDot:1
QUIT
+14 NEW DA,DGFILE,DGMULT,DIC,DIE,DLAYGO,DR,X,Y
+15 SET DIC="^DIC(45.7,"
+16 SET DIC(0)="LXZ"
+17 SET DLAYGO=45.7
+18 SET X=$PIECE(DGSPEC,U,2)
+19 DO ^DIC
+20 SET DGDA1=Y
+21 IF +DGDA1=-1
DO BMES^XPDUTL(" Entry not added to FACILITY TREATING SPECIALTY File(#45.7).")
QUIT
+22 IF $PIECE(DGDA1,U,3)'=1&($PIECE(Y(0),U,2)'=$PIECE(DGSPEC,U))
Begin DoDot:1
+23 DO BMES^XPDUTL(" Entry exists in FACILITY TREATING SPECIALTY File (#45.7), but with")
+24 DO MES^XPDUTL(" a different PTF Code #. No further updating will occur.")
+25 DO MES^XPDUTL(" Please review entry.")
+26 QUIT
End DoDot:1
QUIT
+27 DO BMES^XPDUTL(" Entry "_$SELECT($PIECE(DGDA1,U,3)=1:"added to",1:"exists in")_" FACILITY TREATING SPECIALTY File (#45.7).")
+28 DO MES^XPDUTL(" Updating SPECIALTY field...")
+29 SET DIE=DIC
+30 SET DA=+DGDA1
+31 SET DR="1////"_$PIECE(DGSPEC,U)
+32 DO ^DIE
+33 SET DGFILE=45.7
+34 SET DGMULT=100
+35 SET DIC="^DIC(45.7,"_+DGDA1_",""E"","
+36 DO MULT
+37 QUIT
MULT ;Add Effective Date
+1 NEW DA,DIE,DR
+2 SET DA(1)=+DGDA1
+3 SET DIC(0)="LX"
+4 SET DIC("P")=$PIECE(^DD(DGFILE,DGMULT,0),"^",2)
+5 SET X=3020101
+6 DO ^DIC
+7 SET DA=+Y
+8 IF +Y=-1
DO MES^XPDUTL(" Effective date not added.")
QUIT
+9 DO MES^XPDUTL(" Effective date added.")
+10 SET DIE=DIC
+11 SET DR=".02///Y"
+12 DO ^DIE
+13 QUIT
MOVEMT ;Edit Mas Movement Type Names
+1 NEW DGFILE,DGIEN,DGON,DGNN,FDAROOT
+2 SET DGFILE=405.2
+3 ;Old Name
SET DGON=$PIECE(DGMO,"^",1)
+4 ;New Name
SET DGNN=$PIECE(DGMO,"^",2)
+5 SET DGIEN=$$FIND1^DIC(DGFILE,,"QX",DGNN)
+6 ;New name already in file
IF DGIEN>0
QUIT
+7 ;Old Name
SET DGIEN=$$FIND1^DIC(DGFILE,,"QX",DGON)
+8 ;Didn't find it in file
IF DGIEN'>0
Begin DoDot:1
+9 DO BMES^XPDUTL(" Mas Movement Type '"_DGON_"' not found!")
+10 DO MES^XPDUTL(" Contact the Help Desk.")
End DoDot:1
+11 ;entry found
IF DGIEN>0
Begin DoDot:1
+12 SET FDAROOT(DGFILE,DGIEN_",",.01)=DGNN
+13 DO FILE^DIE("","FDAROOT")
+14 DO BMES^XPDUTL("'"_DGON_"' renamed '"_DGNN_"'")
End DoDot:1
+15 QUIT
TRSP ;PTF code^Speciality^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#
+1 ;;95^INTERMEDIATE MEDICINE - LTC^IM - LTC^I^N^INTERMEDIATE CARE^1415^^POS1
+2 ;;QUIT
MVED ;Original Movement Name^New Movement Name
+1 ;;READMISSION TO NHCU/DOMICILIARY^READMISSION TO IMLTC/NHCU/DOMICILIARY
+2 ;;TO NHCU FROM HOSP^TO IMLTC/NHCU FROM HOSP
+3 ;;TO NHCU FROM DOM^TO IMLTC/NHCU FROM DOM
+4 ;;VA NHCU TO CNH^VA IMLTC/NHCU TO CNH
+5 ;;DISCHARGE FROM NHCU/DOM WHILE ASIH^DISCHARGE FROM IMLTC/NHCU/DOM WHILE ASIH
+6 ;;QUIT
+7 QUIT
