DG53197P ;ALB/JDS
;;5.3;Patient File;**197**;Aug 13, 1993
S ^DD(2,.01,"DEL",999999,0)="D DEL^DPTLK2"
N A S A=$$NEWCP^XPDUTL("DGNAME","POST^DG53197P","")
Q
POST N Q,G,A,B,C,NAME,Q,DIE,DA,XPDIDTOT,DGUP
S A=$$PARCP^XPDUTL("DGNAME"),Q="""",XPDIDTOT=27,DGUP=A
S G="^DPT(""B"","_Q_A_Q_")" D MES^XPDUTL("Checking for Patients with space before comma")
F S G=$Q(@G) Q:G'[("B"_Q) S A=$P(G,Q,4,5) Q:$A(A)>90 S:(DGUP'=$E(A)) B=$$UPCP^XPDUTL("DGNAME",$E(A,1,2)) D:(DGUP'=$E(A)) UPDATE^XPDID($A(A)-64) S DGUP=$E(A) I A[" ," D
.S DA=+$P(A,Q_",",2),NAME=$P($G(^DPT(DA,0)),U)
.I NAME[" ," D MES^XPDUTL(NAME) S NAME=$P(NAME," ,")_","_$P(NAME," ,",2,9) K DR S DR=".01////^S X=NAME",DIE=2 D ^DIE D MES^XPDUTL("Change to "_$P($G(^DPT(DA,0)),U))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53197P 748 printed Dec 13, 2024@02:36:34 Page 2
DG53197P ;ALB/JDS
+1 ;;5.3;Patient File;**197**;Aug 13, 1993
+2 SET ^DD(2,.01,"DEL",999999,0)="D DEL^DPTLK2"
+3 NEW A
SET A=$$NEWCP^XPDUTL("DGNAME","POST^DG53197P","")
+4 QUIT
POST NEW Q,G,A,B,C,NAME,Q,DIE,DA,XPDIDTOT,DGUP
+1 SET A=$$PARCP^XPDUTL("DGNAME")
SET Q=""""
SET XPDIDTOT=27
SET DGUP=A
+2 SET G="^DPT(""B"","_Q_A_Q_")"
DO MES^XPDUTL("Checking for Patients with space before comma")
+3 FOR
SET G=$QUERY(@G)
if G'[("B"_Q)
QUIT
SET A=$PIECE(G,Q,4,5)
if $ASCII(A)>90
QUIT
if (DGUP'=$EXTRACT(A))
SET B=$$UPCP^XPDUTL("DGNAME",$EXTRACT(A,1,2))
if (DGUP'=$EXTRACT(A))
DO UPDATE^XPDID($ASCII(A)-64)
SET DGUP=$EXTRACT(A)
IF A[" ,"
Begin DoDot:1
+4 SET DA=+$PIECE(A,Q_",",2)
SET NAME=$PIECE($GET(^DPT(DA,0)),U)
+5 IF NAME[" ,"
DO MES^XPDUTL(NAME)
SET NAME=$PIECE(NAME," ,")_","_$PIECE(NAME," ,",2,9)
KILL DR
SET DR=".01////^S X=NAME"
SET DIE=2
DO ^DIE
DO MES^XPDUTL("Change to "_$PIECE($GET(^DPT(DA,0)),U))
End DoDot:1
