- XUINEND2 ;SFISC/RWF - CLEAN UP OLD SPOOL DATA ;6/29/92 11:26
- ;;7.0;Kernel;;Jul 17, 1992
- A S U="^"
- F ZISDA=0:0 S ZISDA=$O(^XMB(3.51,ZISDA)) Q:ZISDA'>0 D CHK
- Q
- CHK ;
- S Z0=$G(^XMB(3.51,ZISDA,0)),DA=$P(Z0,U,10)
- Q:DA'>0 I $D(^XMBS(3.519,DA,0)) Q
- Q:'$D(^XMB(3.9,DA,0))
- ;MOVE
- S X=ZISDA,DIC="^XMBS(3.519,",DIC(0)="",DLAYGO=3.519 D FILE^DICN S XS=+Y
- S %X="^XMB(3.9,"_DA_",2,",%Y="^XMBS(3.519,"_XS_",2," D %XY^%RCR
- S $P(^XMB(3.51,ZISDA,0),U,10)=XS,^XMB(3.51,"AM",XS,ZISDA)="" K ^XMB(3.51,"AM",DA,ZISDA)
- S XMDUZ=$P(Z0,U,5),XMZ=DA D KLQ^XMA1B ;Move to waste basket
- Q
- F4 ;Clean-up Institution file fields .04 and 6 both use 0;7 to store data
- S X=$G(^DD(4,6,0)) Q:X'["AMIS"
- S DIK="^DD(4,",DA=6,DA(1)=4 D ^DIK
- Q
- F200 ;Clean-up DUP X-ref in file 200
- I $G(^DD(200,2,1,3,0))["A^MUMPS" S DIK="^DD(200,2,1,",DA=3,DA(1)=2,DA(2)=200 D ^DIK
- Q
- F6 ;Build .01 field of provider file.
- F I=1:2 S X=$E($T(Q+I),4,999) Q:X="" S Y=$E($T(Q+I+1),4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,99) S:$A(Y)=61 Y=$E(Y,2,999) S @X=Y
- Q Q
- ;;^DIC(6,0,"GL")
- ;;=^DIC(6,
- ;;^DIC("B","PROVIDER",6)
- ;;=
- ;;^DD(6,0)
- ;;=FIELD^^100^15
- ;;^DD(6,0,"NM","PROVIDER")
- ;;=
- ;;^DD(6,.01,0)
- ;;=NAME^RP16X^DIC(16,^0;1^S DINUM=X
- ;;^DD(6,.01,1,0)
- ;;=^.1
- ;;^DD(6,.01,1,1,0)
- ;;=6^B
- ;;^DD(6,.01,1,1,1)
- ;;=S ^DIC(6,"B",$E(X,1,30),DA)=""
- ;;^DD(6,.01,1,1,2)
- ;;=K ^DIC(6,"B",$E(X,1,30),DA)
- ;;^DD(6,.01,1,2,0)
- ;;=6^AC^MUMPS
- ;;^DD(6,.01,1,2,1)
- ;;=S ^DIC(16,+X,"A6")=DA
- ;;^DD(6,.01,1,2,1.1)
- ;;=S X=DIV S X=$S('$D(D0):"",D0<0:"",1:D0)
- ;;^DD(6,.01,1,2,1.4)
- ;;=S DIH=$S($D(^DIC(16,DIV(0),"A6")):^("A6"),1:""),DIV=X I $D(^(0)) S %=$P(DIH,U,2,999),DIU=$P(DIH,U,1),^("A6")=DIV_$S(%]"":U_%,1:""),DIH=16,DIG=30.006 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
- ;;^DD(6,.01,1,2,2)
- ;;=K ^DIC(16,+X,"A6")
- ;;^DD(6,.01,1,2,9.2)
- ;;=S I(0,0)=$S($D(D0):D0,1:""),D0=X S:'$D(^DIC(16,+D0,0)) D0=-1 S DIV(0)=D0 S I(100,0)=$S($D(D0):D0,1:""),Y(101)=$S($D(^DIC(16,D0,"A6")):^("A6"),1:"")
- ;;^DD(6,.01,1,2,"CREATE VALUE")
- ;;=NUMBER
- ;;^DD(6,.01,1,2,"DELETE VALUE")
- ;;=NO EFFECT
- ;;^DD(6,.01,1,2,"FIELD")
- ;;=NAME:PROVIDER
- ;;^DD(6,.01,1,3,0)
- ;;=6^AK^MUMPS
- ;;^DD(6,.01,1,3,1)
- ;;=G F6S^XUA4A7
- ;;^DD(6,.01,1,3,2)
- ;;=G F6K^XUA4A7
- ;;^DD(6,.01,1,3,3)
- ;;=Used to link providers to new person keys.
- ;;^DD(6,.01,1,3,"%D",0)
- ;;=^^2^2^2910916^
- ;;^DD(6,.01,1,3,"%D",1,0)
- ;;=This X-ref will see that the provider also has the 'VA Provider'
- ;;^DD(6,.01,1,3,"%D",2,0)
- ;;=key in the New Person file.
- ;;^DD(6,.01,1,3,"DT")
- ;;=2910916
- ;;^DD(6,.01,3)
- ;;=
- ;;^DD(6,.01,5,1,0)
- ;;=16010^30.006^1
- ;;^DD(6,.01,"DT")
- ;;=2910916
- ;;
- XUINEND2 ;SFISC/RWF - CLEAN UP OLD SPOOL DATA ;6/29/92 11:26
- +1 ;;7.0;Kernel;;Jul 17, 1992
- A SET U="^"
- +1 FOR ZISDA=0:0
- SET ZISDA=$ORDER(^XMB(3.51,ZISDA))
- IF ZISDA'>0
- QUIT
- DO CHK
- +2 QUIT
- CHK ;
- +1 SET Z0=$GET(^XMB(3.51,ZISDA,0))
- SET DA=$PIECE(Z0,U,10)
- +2 IF DA'>0
- QUIT
- IF $DATA(^XMBS(3.519,DA,0))
- QUIT
- +3 IF '$DATA(^XMB(3.9,DA,0))
- QUIT
- +4 ;MOVE
- +5 SET X=ZISDA
- SET DIC="^XMBS(3.519,"
- SET DIC(0)=""
- SET DLAYGO=3.519
- DO FILE^DICN
- SET XS=+Y
- +6 SET %X="^XMB(3.9,"_DA_",2,"
- SET %Y="^XMBS(3.519,"_XS_",2,"
- DO %XY^%RCR
- +7 SET $PIECE(^XMB(3.51,ZISDA,0),U,10)=XS
- SET ^XMB(3.51,"AM",XS,ZISDA)=""
- KILL ^XMB(3.51,"AM",DA,ZISDA)
- +8 ;Move to waste basket
- SET XMDUZ=$PIECE(Z0,U,5)
- SET XMZ=DA
- DO KLQ^XMA1B
- +9 QUIT
- F4 ;Clean-up Institution file fields .04 and 6 both use 0;7 to store data
- +1 SET X=$GET(^DD(4,6,0))
- IF X'["AMIS"
- QUIT
- +2 SET DIK="^DD(4,"
- SET DA=6
- SET DA(1)=4
- DO ^DIK
- +3 QUIT
- F200 ;Clean-up DUP X-ref in file 200
- +1 IF $GET(^DD(200,2,1,3,0))["A^MUMPS"
- SET DIK="^DD(200,2,1,"
- SET DA=3
- SET DA(1)=2
- SET DA(2)=200
- DO ^DIK
- +2 QUIT
- F6 ;Build .01 field of provider file.
- +1 FOR I=1:2
- SET X=$EXTRACT($TEXT(Q+I),4,999)
- IF X=""
- QUIT
- SET Y=$EXTRACT($TEXT(Q+I+1),4,999)
- IF $ASCII(Y)=126
- SET I=I+1
- SET Y=$EXTRACT(Y,2,999)_$EXTRACT($TEXT(Q+I+1),5,99)
- IF $ASCII(Y)=61
- SET Y=$EXTRACT(Y,2,999)
- SET @X=Y
- Q QUIT
- +1 ;;^DIC(6,0,"GL")
- +2 ;;=^DIC(6,
- +3 ;;^DIC("B","PROVIDER",6)
- +4 ;;=
- +5 ;;^DD(6,0)
- +6 ;;=FIELD^^100^15
- +7 ;;^DD(6,0,"NM","PROVIDER")
- +8 ;;=
- +9 ;;^DD(6,.01,0)
- +10 ;;=NAME^RP16X^DIC(16,^0;1^S DINUM=X
- +11 ;;^DD(6,.01,1,0)
- +12 ;;=^.1
- +13 ;;^DD(6,.01,1,1,0)
- +14 ;;=6^B
- +15 ;;^DD(6,.01,1,1,1)
- +16 ;;=S ^DIC(6,"B",$E(X,1,30),DA)=""
- +17 ;;^DD(6,.01,1,1,2)
- +18 ;;=K ^DIC(6,"B",$E(X,1,30),DA)
- +19 ;;^DD(6,.01,1,2,0)
- +20 ;;=6^AC^MUMPS
- +21 ;;^DD(6,.01,1,2,1)
- +22 ;;=S ^DIC(16,+X,"A6")=DA
- +23 ;;^DD(6,.01,1,2,1.1)
- +24 ;;=S X=DIV S X=$S('$D(D0):"",D0<0:"",1:D0)
- +25 ;;^DD(6,.01,1,2,1.4)
- +26 ;;=S DIH=$S($D(^DIC(16,DIV(0),"A6")):^("A6"),1:""),DIV=X I $D(^(0)) S %=$P(DIH,U,2,999),DIU=$P(DIH,U,1),^("A6")=DIV_$S(%]"":U_%,1:""),DIH=16,DIG=30.006 D ^DICR:$N(^DD(DIH,DIG,1,0))>0
- +27 ;;^DD(6,.01,1,2,2)
- +28 ;;=K ^DIC(16,+X,"A6")
- +29 ;;^DD(6,.01,1,2,9.2)
- +30 ;;=S I(0,0)=$S($D(D0):D0,1:""),D0=X S:'$D(^DIC(16,+D0,0)) D0=-1 S DIV(0)=D0 S I(100,0)=$S($D(D0):D0,1:""),Y(101)=$S($D(^DIC(16,D0,"A6")):^("A6"),1:"")
- +31 ;;^DD(6,.01,1,2,"CREATE VALUE")
- +32 ;;=NUMBER
- +33 ;;^DD(6,.01,1,2,"DELETE VALUE")
- +34 ;;=NO EFFECT
- +35 ;;^DD(6,.01,1,2,"FIELD")
- +36 ;;=NAME:PROVIDER
- +37 ;;^DD(6,.01,1,3,0)
- +38 ;;=6^AK^MUMPS
- +39 ;;^DD(6,.01,1,3,1)
- +40 ;;=G F6S^XUA4A7
- +41 ;;^DD(6,.01,1,3,2)
- +42 ;;=G F6K^XUA4A7
- +43 ;;^DD(6,.01,1,3,3)
- +44 ;;=Used to link providers to new person keys.
- +45 ;;^DD(6,.01,1,3,"%D",0)
- +46 ;;=^^2^2^2910916^
- +47 ;;^DD(6,.01,1,3,"%D",1,0)
- +48 ;;=This X-ref will see that the provider also has the 'VA Provider'
- +49 ;;^DD(6,.01,1,3,"%D",2,0)
- +50 ;;=key in the New Person file.
- +51 ;;^DD(6,.01,1,3,"DT")
- +52 ;;=2910916
- +53 ;;^DD(6,.01,3)
- +54 ;;=
- +55 ;;^DD(6,.01,5,1,0)
- +56 ;;=16010^30.006^1
- +57 ;;^DD(6,.01,"DT")
- +58 ;;=2910916
- +59 ;;
